Mercurial > emacs
changeset 110855:bec49af30c2f
Merge changes from emacs-23 branch.
| author | Juanma Barranquero <lekktu@gmail.com> |
|---|---|
| date | Fri, 08 Oct 2010 12:14:47 +0200 |
| parents | e60b0b3ed516 (current diff) 24b574ef691b (diff) |
| children | 86c4eea71813 |
| files | doc/lispref/ChangeLog doc/misc/ChangeLog doc/misc/cl.texi lib-src/ChangeLog lib-src/emacsclient.c lisp/ChangeLog lisp/cedet/ChangeLog lisp/cedet/semantic/mru-bookmark.el lisp/dired.el lisp/dnd.el lisp/emacs-lisp/cl-compat.el lisp/emacs-lisp/lmenu.el lisp/emacs-lisp/shadow.el lisp/minibuffer.el lisp/obsolete/cl-compat.el lisp/obsolete/lmenu.el lisp/server.el lisp/vc/vc-svn.el src/ChangeLog src/buffer.c src/callproc.c src/coding.c src/coding.h src/dbusbind.c src/keyboard.c src/process.c src/xfont.c |
| diffstat | 36 files changed, 1132 insertions(+), 883 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/lispref/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/doc/lispref/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -2458,6 +2458,12 @@ * display.texi (Images): Delete redundant @findex. +2007-08-16 Stefan Monnier <monnier@iro.umontreal.ca> + + * text.texi (Change Hooks): (after|before)-change-functions are no + longer bound to nil while running; rather inhibit-modification-hooks + is t. + 2007-08-16 Richard Stallman <rms@gnu.org> * processes.texi (Asynchronous Processes): Clarify
--- a/doc/misc/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/doc/misc/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -1,3 +1,11 @@ +2010-10-08 Glenn Morris <rgm@gnu.org> + + * cl.texi (Organization, Installation, Old CL Compatibility): + Deprecate cl-compat for new code. + (Usage, Installation): Remove outdated information. + + * eudc.texi (CCSO PH/QI, LDAP Requirements): Remove old information. + 2010-10-07 Katsumi Yamaoka <yamaoka@jpl.org> * gnus.texi (Gravatars): Document gnus-gravatar-too-ugly.
--- a/doc/misc/cl.texi Fri Oct 08 00:51:19 2010 -0700 +++ b/doc/misc/cl.texi Fri Oct 08 12:14:47 2010 +0200 @@ -163,19 +163,6 @@ @end example @noindent -If you want to ensure that the new (Gillespie) version of @dfn{CL} -is the one that is present, add an additional @code{(require 'cl-19)} -call: - -@example -(require 'cl) -(require 'cl-19) -@end example - -@noindent -The second call will fail (with ``@file{cl-19.el} not found'') if -the old @file{cl.el} package was in use. - It is safe to arrange to load @dfn{CL} at all times, e.g., in your @file{.emacs} file. But it's a good idea, for portability, to @code{(require 'cl)} in your code even if you do this. @@ -219,39 +206,26 @@ needed. There is another file, @file{cl-compat.el}, which defines some -routines from the older @file{cl.el} package that are no longer +routines from the older @file{cl.el} package that are not otherwise present in the new package. This includes internal routines like @code{setelt} and @code{zip-lists}, deprecated features like @code{defkeyword}, and an emulation of the old-style -multiple-values feature. @xref{Old CL Compatibility}. +multiple-values feature. This file is obsolete and should not be used +in new code. @xref{Old CL Compatibility}. @node Installation, Naming Conventions, Organization, Overview @section Installation @noindent -Installation of the @dfn{CL} package is simple: Just put the -byte-compiled files @file{cl.elc}, @file{cl-extra.elc}, -@file{cl-seq.elc}, @file{cl-macs.elc}, and @file{cl-compat.elc} -into a directory on your @code{load-path}. - -There are no special requirements to compile this package: -The files do not have to be loaded before they are compiled, -nor do they need to be compiled in any particular order. - -You may choose to put the files into your main @file{lisp/} -directory, replacing the original @file{cl.el} file there. Or, -you could put them into a directory that comes before @file{lisp/} -on your @code{load-path} so that the old @file{cl.el} is -effectively hidden. - -Also, format the @file{cl.texinfo} file and put the resulting -Info files in the @file{info/} directory or another suitable place. - -You may instead wish to leave this package's components all in -their own directory, and then add this directory to your -@code{load-path} and @code{Info-directory-list}. -Add the directory to the front of the list so the old @dfn{CL} -package and its documentation are hidden. +The @dfn{CL} package is distributed with Emacs, so there is no need +to install anything. + +If you do need to install it, just put the byte-compiled files +@file{cl.elc}, @file{cl-extra.elc}, @file{cl-seq.elc}, +@file{cl-macs.elc}, and (if necessary) @file{cl-compat.elc} into a +directory on your @code{load-path}. Also, format the @file{cl.texi} +file and put the resulting Info files into a directory in your +@code{Info-directory-list}. @node Naming Conventions, , Installation, Overview @section Naming Conventions @@ -5076,8 +5050,8 @@ @noindent The @dfn{CL} package includes emulations of some features of the old @file{cl.el}, in the form of a compatibility package -@code{cl-compat}. To use it, put @code{(require 'cl-compat)} in -your program. +@code{cl-compat}. This file is obsolete and may be removed in future, +so it should not be used in new code. The old package defined a number of internal routines without @code{cl-} prefixes or other annotations. Call to these routines
--- a/doc/misc/eudc.texi Fri Oct 08 00:51:19 2010 -0700 +++ b/doc/misc/eudc.texi Fri Oct 08 12:14:47 2010 +0200 @@ -137,7 +137,7 @@ LDAP servers usually store (but are not limited to) information about people such as their name, phone number, email address, office location, etc@enddots{} More information about LDAP can be found at -@url{http://www.openldap.org/} +@url{http://www.openldap.org/}. EUDC requires external support to access LDAP directory servers (@pxref{LDAP Requirements}) @@ -148,17 +148,15 @@ @section CCSO PH/QI The Central Computing Services Office (CCSO) of the University of -Illinois at Urbana Champaign (UIUC) created and freely distributes a -directory system that is currently in use in more than 300 organizations -around the world. The system records information about people such as -their address, phone number, email, academic information or any other -details it was configured to. +Illinois at Urbana Champaign created and freely distributed a +directory system that was used by many organizations in the 1990s. +The system records information about people such as their address, +phone number, email, academic information or any other details it was +configured to. Nowadays this system is not widely used. The system consists of two parts: a database server traditionally called -@samp{qi} and a command-line client called @samp{ph}. -@url{ftp://uiarchive.cso.uiuc.edu/pub/packages/ph} is the main -distribution site. @url{http://www.uiuc.edu/cgi-bin/ph/lookup?Query=.} -provides a listing of the active @samp{qi} servers. +@samp{qi} and a command-line client called @samp{ph}. As of 2010, the +code can still be downloaded from @url{http://www-dev.cites.uiuc.edu/ph/}. The original command-line @samp{ph} client that comes with the @samp{ph/qi} distribution provides additional features like the @@ -225,18 +223,10 @@ @comment node-name, next, previous, up @section LDAP Requirements -LDAP support is added by means of @file{ldap.el} which is part of Emacs. +LDAP support is added by means of @file{ldap.el}, which is part of Emacs. @file{ldap.el} needs an external command line utility named -@file{ldapsearch} which is available as part of LDAP toolkits: - -@itemize @bullet -@item -Open LDAP Libraries -(@url{http://www.openldap.org/}) -@item -University of Michigan's LDAP Client software -(@url{http://www.umich.edu/~dirsvcs/ldap/}) -@end itemize +@file{ldapsearch}, available as part of Open LDAP +(@url{http://www.openldap.org/}). @node Usage, Credits, Installation, Top @@ -968,7 +958,3 @@ @printindex vr @bye - -@ignore - arch-tag: 1b79460b-4ea1-441d-ab45-05ddd16ef241 -@end ignore
--- a/lib-src/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/lib-src/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -1,3 +1,8 @@ +2010-10-08 Glenn Morris <rgm@gnu.org> + + * emacsclient.c (set_local_socket) [DARWIN_OS]: Try as a fall-back + DARWIN_USER_TEMP_DIR. (Bug#3992) + 2010-10-03 Dan Nicolaescu <dann@ics.uci.edu> * test-distrib.c (cool_read):
--- a/lib-src/emacsclient.c Fri Oct 08 00:51:19 2010 -0700 +++ b/lib-src/emacsclient.c Fri Oct 08 12:14:47 2010 +0200 @@ -1223,7 +1223,18 @@ { tmpdir = egetenv ("TMPDIR"); if (!tmpdir) - tmpdir = "/tmp"; + { +#ifdef DARWIN_OS + size_t n = confstr (_CS_DARWIN_USER_TEMP_DIR, NULL, (size_t) 0); + if (n > 0) + { + tmpdir = alloca (n); + confstr (_CS_DARWIN_USER_TEMP_DIR, tmpdir, n); + } + else +#endif + tmpdir = "/tmp"; + } socket_name = alloca (strlen (tmpdir) + strlen (server_name) + EXTRA_SPACE); sprintf (socket_name, "%s/emacs%d/%s",
--- a/lisp/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -1,3 +1,49 @@ +2010-10-08 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/cl-compat.el, emacs-lisp/lmenu.el: Move to obsolete/. + + * emacs-lisp/shadow.el (lisp-shadow): Change prefix. + (shadows-compare-text-p): Make it an obsolete alias for... + (load-path-shadows-compare-text): ... new name. + (find-emacs-lisp-shadows): Update for above name change. + (load-path-shadows-same-file-or-nonexistent): New name for the old + shadow-same-file-or-nonexistent. + +2010-10-08 Chong Yidong <cyd@stupidchicken.com> + + * minibuffer.el (completion--some, completion--do-completion) + (minibuffer-complete-and-exit, minibuffer-completion-help) + (completion-basic-try-completion) + (completion-basic-all-completions) + (completion-pcm--find-all-completions): Use lexical-let to + avoid some false matches in variable completion (Bug#7056) + +2010-10-08 Olof Ohlsson Sax <olof.ohlsson.sax@gmail.com> (tiny change) + + * vc-svn.el (vc-svn-merge-news): Use --non-interactive. (Bug#7152) + +2010-10-08 Leo <sdl.web@gmail.com> + + * dnd.el (dnd-get-local-file-name): If MUST-EXIST is non-nil, only + return non-nil if the file exists (Bug#7090). + +2010-10-08 Stefan Monnier <monnier@iro.umontreal.ca> + + * minibuffer.el (completion--replace): + Better preserve markers (bug#7138). + +2010-10-08 Juanma Barranquero <lekktu@gmail.com> + + * server.el (server-process-filter): Doc fix. + +2010-10-08 Drew Adams <drew.adams@oracle.com> + + * dired.el (dired-save-positions): Doc fix. (Bug#7119) + +2010-10-08 Andreas Schwab <schwab@linux-m68k.org> + + * Makefile.in (ELCFILES): Update. + 2010-10-08 Glenn Morris <rgm@gnu.org> * vc/ediff-wind.el (ediff-setup-control-frame):
--- a/lisp/cedet/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -1,3 +1,32 @@ +2010-09-30 Chong Yidong <cyd@stupidchicken.com> + + * semantic/bovine/el.el: + * semantic/mru-bookmark.el (global-semantic-mru-bookmark-mode): + Fix require statements. + +2010-09-29 Chong Yidong <cyd@stupidchicken.com> + + * semantic/tag.el (semantic-tag-version): Bump to 2.0. + + * semantic/db-typecache.el (semanticdb-typecache-find-default): + * semantic/imenu.el (semantic-create-imenu-index): + * semantic/grammar.el (semantic--grammar-macro-function-tag): + * semantic/fw.el (semanticdb-without-unloaded-file-searches): Fix + require. Suggested by David Engster. + + * semantic/bovine/c-by.el: Regenerate. + +2010-09-29 Eric Ludlam <zappo@gnu.org> + + * semantic/lex-spp.el (semantic-lex-spp-debug-symbol): New var. + (semantic-lex-spp-enable-debug-symbol): New command + (semantic-lex-spp-value-valid-p) + (semantic-lex-spp-validate-value): New functions + (semantic-lex-spp-symbol-set) + (semantic-lex-spp-symbol-push): Add call to validate value. + (semantic-lex-spp-table-write-slot-value): Instead of erroring on + invalid values during save, just save a nil. + 2010-09-25 Chong Yidong <cyd@stupidchicken.com> * ede/linux.el (ede-project-class-files): @@ -465,11 +494,6 @@ (ede-dired-minor-mode): Use define-minor-mode and derived-mode-p. (ede-dired-add-to-target): Use dolist. -2010-04-18 Chong Yidong <cyd@stupidchicken.com> - - * ede/pmake.el (ede-proj-makefile-insert-variables): - Don't destroy list before using it. - 2010-04-29 Chong Yidong <cyd@stupidchicken.com> * semantic.el (semantic-completion-at-point-function):
--- a/lisp/cedet/semantic/bovine/c-by.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/bovine/c-by.el Fri Oct 08 12:14:47 2010 +0200 @@ -1240,7 +1240,9 @@ (nth 7 vals)) (nth 0 vals) (nth 10 vals) - (nth 4 vals)) + (list + (nth 4 vals)) + (nth 9 vals)) ) (opt-stars opt-class @@ -1262,7 +1264,9 @@ (nth 6 vals)) (nth 0 vals) (nth 9 vals) - (nth 4 vals)) + (list + (nth 4 vals)) + (nth 8 vals)) ) ) ;; end func-decl @@ -1433,13 +1437,11 @@ namespace-symbol opt-bits opt-array - opt-assign ,(semantic-lambda (nth 2 vals) (nth 0 vals) (nth 3 vals) - (nth 4 vals) - (nth 5 vals)) + (nth 4 vals)) ) ) ;; end varname @@ -1484,19 +1486,28 @@ ) ) ;; end variablearg-opt-name + (varname-opt-initializer + (semantic-list) + (opt-assign) + ( ;;EMPTY + ) + ) ;; end varname-opt-initializer + (varnamelist (opt-ref varname + varname-opt-initializer punctuation "\\`[,]\\'" varnamelist ,(semantic-lambda (cons (nth 1 vals) - (nth 3 vals))) + (nth 4 vals))) ) (opt-ref varname + varname-opt-initializer ,(semantic-lambda (list (nth 1 vals))) @@ -2108,74 +2119,64 @@ "\\`[&]\\'") ) ;; end expr-start + (expr-binop + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[/]\\'") + (punctuation + "\\`[&]\\'" + punctuation + "\\`[&]\\'") + (punctuation + "\\`[&]\\'") + (punctuation + "\\`[|]\\'" + punctuation + "\\`[|]\\'") + (punctuation + "\\`[|]\\'") + ) ;; end expr-binop + (expression - (number - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (multi-stage-dereference - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (NEW - multi-stage-dereference - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (NEW - builtintype-types - semantic-list + (unaryexpression + expr-binop + unaryexpression ,(semantic-lambda (list (identity start) (identity end))) ) - (namespace-symbol - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (string-seq - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (type-cast - expression - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (semantic-list - expression - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (semantic-list - ,(semantic-lambda - (list - (identity start) - (identity end))) - ) - (expr-start - expression + (unaryexpression ,(semantic-lambda (list (identity start) (identity end))) ) ) ;; end expression + + (unaryexpression + (number) + (multi-stage-dereference) + (NEW + multi-stage-dereference) + (NEW + builtintype-types + semantic-list) + (namespace-symbol) + (string-seq) + (type-cast + expression) + (semantic-list + expression) + (semantic-list) + (expr-start + expression) + ) ;; end unaryexpression ) "Parser table.")
--- a/lisp/cedet/semantic/bovine/el.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/bovine/el.el Fri Oct 08 12:14:47 2010 +0200 @@ -958,7 +958,7 @@ (add-hook 'lisp-mode-hook 'semantic-default-elisp-setup) (eval-after-load "semanticdb" - '(require 'semanticdb-el) + '(require 'semantic/db-el) ) (provide 'semantic/bovine/el)
--- a/lisp/cedet/semantic/db-typecache.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/db-typecache.el Fri Oct 08 12:14:47 2010 +0200 @@ -403,7 +403,7 @@ PATH is the search path, which should be one table object. If FIND-FILE-MATCH is non-nil, then force the file belonging to the found tag to be loaded." - (if (not (and (featurep 'semanticdb) semanticdb-current-database)) + (if (not (and (featurep 'semantic/db) semanticdb-current-database)) nil ;; No DB, no search (save-excursion (semanticdb-typecache-find-method (or path semanticdb-current-table)
--- a/lisp/cedet/semantic/fw.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/fw.el Fri Oct 08 12:14:47 2010 +0200 @@ -315,7 +315,7 @@ (defmacro semanticdb-without-unloaded-file-searches (forms) "Execute FORMS with `unloaded' removed from the current throttle." `(let ((semanticdb-find-default-throttle - (if (featurep 'semanticdb-find) + (if (featurep 'semantic/db-find) (remq 'unloaded semanticdb-find-default-throttle) nil))) ,forms))
--- a/lisp/cedet/semantic/grammar.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/grammar.el Fri Oct 08 12:14:47 2010 +0200 @@ -1519,7 +1519,7 @@ (car (semantic-find-tags-by-class 'function (or (semantic-find-tags-by-name name (current-buffer)) - (and (featurep 'semanticdb) + (and (featurep 'semantic/db) semanticdb-current-database (cdar (semanticdb-find-tags-by-name name nil t)))))))
--- a/lisp/cedet/semantic/imenu.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/imenu.el Fri Oct 08 12:14:47 2010 +0200 @@ -235,7 +235,7 @@ (setq imenu-default-goto-function 'semantic-imenu-goto-function) (prog1 (if (and semantic-imenu-index-directory - (featurep 'semanticdb) + (featurep 'semantic/db) (semanticdb-minor-mode-p)) (semantic-create-imenu-directory-index (or stream (semantic-fetch-tags-fast)))
--- a/lisp/cedet/semantic/lex-spp.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/lex-spp.el Fri Oct 08 12:14:47 2010 +0200 @@ -173,10 +173,42 @@ (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack (make-vector 13 0)))) +(defun semantic-lex-spp-value-valid-p (value) + "Return non-nil if VALUE is valid." + (or (null value) + (stringp value) + (and (consp value) + (or (semantic-lex-token-p (car value)) + (eq (car (car value)) 'spp-arg-list))))) + +(defvar semantic-lex-spp-debug-symbol nil + "A symbol to break on if it is being set somewhere.") + +(defun semantic-lex-spp-enable-debug-symbol (sym) + "Enable debugging for symbol SYM. +Disable debugging by entering nothing." + (interactive "sSymbol: ") + (if (string= sym "") + (setq semantic-lex-spp-debug-symbol nil) + (setq semantic-lex-spp-debug-symbol sym))) + +(defmacro semantic-lex-spp-validate-value (name value) + "Validate the NAME and VALUE of a macro before it is set." +; `(progn +; (when (not (semantic-lex-spp-value-valid-p ,value)) +; (error "Symbol \"%s\" with bogus value %S" ,name ,value)) +; (when (and semantic-lex-spp-debug-symbol +; (string= semantic-lex-spp-debug-symbol name)) +; (debug)) +; ) + nil + ) + (defun semantic-lex-spp-symbol-set (name value &optional obarray-in) "Set value of spp symbol with NAME to VALUE and return VALUE. If optional OBARRAY-IN is non-nil, then use that obarray instead of the dynamic map." + (semantic-lex-spp-validate-value name value) (if (and (stringp value) (string= value "")) (setq value nil)) (set (intern name (or obarray-in (semantic-lex-spp-dynamic-map))) @@ -192,6 +224,7 @@ (defun semantic-lex-spp-symbol-push (name value) "Push macro NAME with VALUE into the map. Reverse with `semantic-lex-spp-symbol-pop'." + (semantic-lex-spp-validate-value name value) (let* ((map (semantic-lex-spp-dynamic-map)) (stack (semantic-lex-spp-dynamic-map-stack)) (mapsym (intern name map))
--- a/lisp/cedet/semantic/mru-bookmark.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/mru-bookmark.el Fri Oct 08 12:14:47 2010 +0200 @@ -239,6 +239,18 @@ ;; ;; Tracking minor mode. +(defcustom global-semantic-mru-bookmark-mode nil + "If non-nil, enable `semantic-mru-bookmark-mode' globally. +When this mode is enabled, Emacs keeps track of which tags have +been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-mru-bookmark-mode (if val 1 -1)))) + ;;;###autoload (define-minor-mode global-semantic-mru-bookmark-mode "Toggle global use of option `semantic-mru-bookmark-mode'.
--- a/lisp/cedet/semantic/tag.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/cedet/semantic/tag.el Fri Oct 08 12:14:47 2010 +0200 @@ -53,7 +53,7 @@ (declare-function semantic-fetch-tags "semantic") (declare-function semantic-clear-toplevel-cache "semantic") -(defconst semantic-tag-version "2.0pre7" +(defconst semantic-tag-version "2.0" "Version string of semantic tags made with this code.") (defconst semantic-tag-incompatible-version "1.0" @@ -221,6 +221,7 @@ ;; beginning of TAG. (or (and (>= (point) start) (< (point) end)) (goto-char start)) + (require 'semantic/ctxt) (semantic-ctxt-current-mode))))) (defsubst semantic--tag-attributes-cdr (tag)
--- a/lisp/dired.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/dired.el Fri Oct 08 12:14:47 2010 +0200 @@ -1178,7 +1178,7 @@ The positions have the form (BUFFER-POSITION WINDOW-POSITIONS). BUFFER-POSITION is the point position in the current dired buffer. -The buffer position have the form (BUFFER DIRED-FILENAME BUFFER-POINT). +It has the form (BUFFER DIRED-FILENAME BUFFER-POINT). WINDOW-POSITIONS are current positions in all windows displaying this dired buffer. The window positions have the form (WINDOW
--- a/lisp/dnd.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/dnd.el Fri Oct 08 12:14:47 2010 +0200 @@ -155,10 +155,11 @@ (let* ((decoded-f (decode-coding-string f (or file-name-coding-system - default-file-name-coding-system))) - (try-f (if (file-readable-p decoded-f) decoded-f f))) - (when (file-readable-p try-f) try-f))))) - + default-file-name-coding-system)))) + (setq f (cond ((file-readable-p decoded-f) decoded-f) + ((file-readable-p f) f) + (t nil))))) + f)) (defun dnd-open-local-file (uri action) "Open a local file.
--- a/lisp/emacs-lisp/cl-compat.el Fri Oct 08 00:51:19 2010 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,199 +0,0 @@ -;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) - -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions -;; Package: emacs - -;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>. - -;;; 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 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: - -;; This used to be: -;; (or (featurep 'cl) (require 'cl)) -;; which just has the effect of fooling the byte-compiler into not -;; loading cl when compiling. However, that leads to some bogus -;; compiler warnings. Loading cl when compiling cannot do any harm, -;; because for a long time bootstrap-emacs contained 'cl, due to being -;; dumped from uncompiled files that eval-when-compile'd cl. So every -;; file was compiled with 'cl loaded. -(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 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. - -(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) - (declare (indent 1)) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (declare (indent 2)) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (declare (indent 2)) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (declare (indent 1)) - (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 (lambda (x) (make-symbol "--cl-var--")) 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) - -;; Local variables: -;; byte-compile-warnings: (not cl-functions) -;; End: - -;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163 -;;; cl-compat.el ends here
--- a/lisp/emacs-lisp/lmenu.el Fri Oct 08 00:51:19 2010 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,443 +0,0 @@ -;;; lmenu.el --- emulate Lucid's menubar support - -;; Copyright (C) 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Keywords: emulations obsolete - -;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - - -;; First, emulate the Lucid menubar support in GNU Emacs 19. - -;; Arrange to use current-menubar to set up part of the menu bar. - -(defvar current-menubar) -(defvar lucid-menubar-map) -(defvar lucid-failing-menubar) - -(defvar recompute-lucid-menubar 'recompute-lucid-menubar) -(defun recompute-lucid-menubar () - (define-key lucid-menubar-map [menu-bar] - (condition-case nil - (make-lucid-menu-keymap "menu-bar" current-menubar) - (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") - (sit-for 1) - (setq lucid-failing-menubar current-menubar - current-menubar nil)))) - (setq lucid-menu-bar-dirty-flag nil)) - -(defvar lucid-menubar-map (make-sparse-keymap)) -(or (assq 'current-menubar minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'current-menubar lucid-menubar-map) - minor-mode-map-alist))) - -;; XEmacs compatibility -(defun set-menubar-dirty-flag () - (force-mode-line-update) - (setq lucid-menu-bar-dirty-flag t)) - -(defvar add-menu-item-count 0) - -;; This is a variable whose value is always nil. -(defvar make-lucid-menu-keymap-disable nil) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -(defun make-lucid-menu-keymap (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let ((item (car menu-items)) - command name callback) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (make-lucid-menu-keymap (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - add-menu-item-count)) - add-menu-item-count (1+ add-menu-item-count) - name (aref item 0) - callback (aref item 1)) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t) - (let ((i 2)) - (while (< i (length item)) - (cond - ((eq (aref item i) ':active) - (put command 'menu-enable - (or (aref item (1+ i)) - 'make-lucid-menu-keymap-disable)) - (setq i (+ 2 i))) - ((eq (aref item i) ':suffix) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':keys) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':style) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':selected) - ;; unimplemented - (setq i (+ 2 i))) - ((and (symbolp (aref item i)) - (= ?: (string-to-char (symbol-name (aref item i))))) - (error "Unrecognized menu item keyword: %S" - (aref item i))) - ((= i 2) - ;; old-style format: active-p &optional suffix - (put command 'menu-enable - (or (aref item i) 'make-lucid-menu-keymap-disable)) - ;; suffix is unimplemented - (setq i (length item))) - (t - (error "Unexpected menu item value: %S" - (aref item i)))))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (setq menu-items (cdr menu-items))) - menu)) - -(declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) - -;; XEmacs compatibility function -(defun popup-dialog-box (data) - "Pop up a dialog box. -A dialog box description is a list. - - - The first element of the list is a string to display in the dialog box. - - The rest of the elements are descriptions of the dialog box's buttons. - Each one is a vector of three elements: - - The first element is the text of the button. - - The second element is the `callback'. - - The third element is t or nil, whether this button is selectable. - -If the `callback' of a button is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -One (and only one) of the buttons may be nil. This marker means that all -following buttons should be flushright instead of flushleft. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t, nil, or a form to evaluate to decide whether this - button should be selectable> - name := <string> - partition := 'nil' - button := '[' name callback active-p ']' - dialog := '(' name [ button ]+ [ partition [ button ]+ ] ')'" - (let ((name (car data)) - (tail (cdr data)) - converted - choice meaning) - (while tail - (if (null (car tail)) - (setq converted (cons nil converted)) - (let ((item (aref (car tail) 0)) - (callback (aref (car tail) 1)) - (enable (aref (car tail) 2))) - (setq converted - (cons (if enable (cons item callback) item) - converted)))) - (setq tail (cdr tail))) - (setq choice (x-popup-dialog t (cons name (nreverse converted)))) - (if choice - (if (symbolp choice) - (call-interactively choice) - (eval choice))))) - -;; This is empty because the usual elements of the menu bar -;; are provided by menu-bar.el instead. -;; It would not make sense to duplicate them here. -(defconst default-menubar nil) - -;; XEmacs compatibility -(defun set-menubar (menubar) - "Set the default menubar to be menubar." - (setq-default current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - -;; XEmacs compatibility -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be menubar." - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - - -;;; menu manipulation functions - -;; XEmacs compatibility -(defun find-menu-item (menubar item-path-list &optional parent) - "Searches MENUBAR for item given by ITEM-PATH-LIST. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -Signals an error if the item is not found." - (or parent (setq item-path-list (mapcar 'downcase item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (downcase (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 "not a submenu" result)) - (signal 'error (list "no such submenu" (car item-path-list))))) - (cons result parent))))) - - -;; XEmacs compatibility -(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\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (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 "can't disable menus, only menu items")) - (aset item 2 nil) - (set-menubar-dirty-flag) - item)) - - -;; XEmacs compatibility -(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\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (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)) - (aset item 2 t) - (set-menubar-dirty-flag) - item)) - - -(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) - (if before (setq before (downcase before))) - (let* ((menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item (if (listp menu) - (car (find-menu-item (cdr menu) (list item-name))) - (signal 'error (list "not a submenu" menu-path))))) - (or 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)))))) - (or menu - (let ((rest2 so-far)) - (or rest2 - (error "Trying to modify a menu that doesn't exist")) - (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))))) - (or menu (setq menu menubar)) - (if item - nil ; it's already there - (if item-p - (setq item (vector item-name item-data enabled-p)) - (setq item (cons item-name item-data))) - ;; if BEFORE is specified, try to add it there. - (if 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 item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (if (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 item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list item)))))) - (if item-p - (progn - (aset item 1 item-data) - (aset item 2 (not (null enabled-p)))) - (setcar item item-name) - (setcdr item item-data)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu-item (menu-path item-name function enabled-p &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\". -ITEM-NAME is the string naming the menu item to be added. -FUNCTION is the command to invoke when this menu item is selected. - If it is a symbol, then it is invoked with `call-interactively', in the same - way that functions bound to keys are invoked. If it is a list, then the - list is simply evaluated. -ENABLED-P controls whether the item is selectable or not. -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." - (or menu-path (error "must specify a menu path")) - (or item-name (error "must specify an item name")) - (add-menu-item-1 t menu-path item-name function enabled-p before)) - - -;; XEmacs compatibility -(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. (\"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\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (or (cdr pair) menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq menu current-menubar) - (setq current-menubar (delq item menu)) - (delq item menu)) - (set-menubar-dirty-flag) - item))) - - -;; XEmacs compatibility -(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 "No such menu item" "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)) - -;; XEmacs compatibility -(defun add-menu (menu-path menu-name menu-items &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. -MENU-NAME is the string naming the menu to be added. -MENU-ITEMS is a list of menu item descriptions. - Each menu item should be a vector of three elements: - - a string, the name of the menu item; - - a symbol naming a command, or a form to evaluate; - - and a form whose value determines whether this item is selectable. -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." - (or menu-name (error "must specify a menu name")) - (or menu-items (error "must specify some menu items")) - (add-menu-item-1 nil menu-path menu-name menu-items t before)) - - - -(defvar put-buffer-names-in-file-menu t) - - -;; Don't unconditionally enable menu bars; leave that up to the user. -;;(let ((frames (frame-list))) -;; (while frames -;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) -;; (setq frames (cdr frames)))) -;;(or (assq 'menu-bar-lines default-frame-alist) -;; (setq default-frame-alist -;; (cons '(menu-bar-lines . 1) default-frame-alist))) - -(set-menubar default-menubar) - -(provide 'lmenu) - -;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1 -;;; lmenu.el ends here
--- a/lisp/emacs-lisp/shadow.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/emacs-lisp/shadow.el Fri Oct 08 12:14:47 2010 +0200 @@ -53,10 +53,13 @@ (defgroup lisp-shadow nil "Locate Emacs Lisp file shadowings." - :prefix "shadows-" + :prefix "load-path-shadows-" :group 'lisp) -(defcustom shadows-compare-text-p nil +(define-obsolete-variable-alias 'shadows-compare-text-p + 'load-path-shadows-compare-text "23.3") + +(defcustom load-path-shadows-compare-text nil "If non-nil, then shadowing files are reported only if their text differs. This is slower, but filters out some innocuous shadowing." :type 'boolean @@ -124,11 +127,11 @@ ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" file)) (base2 (concat dir "/" file))) - (if (not (and shadows-compare-text-p - (shadow-same-file-or-nonexistent + (if (not (and load-path-shadows-compare-text + (load-path-shadows-same-file-or-nonexistent (concat base1 ".el") (concat base2 ".el")) ;; This is a bit strict, but safe. - (shadow-same-file-or-nonexistent + (load-path-shadows-same-file-or-nonexistent (concat base1 ".elc") (concat base2 ".elc")))) (setq shadows (append shadows (list base1 base2))))) @@ -140,7 +143,7 @@ ;; Return true if neither file exists, or if both exist and have identical ;; contents. -(defun shadow-same-file-or-nonexistent (f1 f2) +(defun load-path-shadows-same-file-or-nonexistent (f1 f2) (let ((exists1 (file-exists-p f1)) (exists2 (file-exists-p f2))) (or (and (not exists1) (not exists2))
--- a/lisp/minibuffer.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/minibuffer.el Fri Oct 08 12:14:47 2010 +0200 @@ -133,8 +133,8 @@ "Apply FUN to each element of XS in turn. Return the first non-nil returned value. Like CL's `some'." - (let ((firsterror nil) - res) + (lexical-let ((firsterror nil) + res) (while (and (not res) xs) (condition-case err (setq res (funcall fun (pop xs))) @@ -485,10 +485,30 @@ (defun completion--replace (beg end newtext) "Replace the buffer text between BEG and END with NEWTEXT. Moves point to the end of the new text." - ;; This should be in subr.el. + ;; Maybe this should be in subr.el. ;; You'd think this is trivial to do, but details matter if you want ;; to keep markers "at the right place" and be robust in the face of ;; after-change-functions that may themselves modify the buffer. + (let ((prefix-len 0)) + ;; Don't touch markers in the shared prefix (if any). + (while (and (< prefix-len (length newtext)) + (< (+ beg prefix-len) end) + (eq (char-after (+ beg prefix-len)) + (aref newtext prefix-len))) + (setq prefix-len (1+ prefix-len))) + (unless (zerop prefix-len) + (setq beg (+ beg prefix-len)) + (setq newtext (substring newtext prefix-len)))) + (let ((suffix-len 0)) + ;; Don't touch markers in the shared suffix (if any). + (while (and (< suffix-len (length newtext)) + (< beg (- end suffix-len)) + (eq (char-before (- end suffix-len)) + (aref newtext (- (length newtext) suffix-len 1)))) + (setq suffix-len (1+ suffix-len))) + (unless (zerop suffix-len) + (setq end (- end suffix-len)) + (setq newtext (substring newtext 0 (- suffix-len))))) (goto-char beg) (insert newtext) (delete-region (point) (+ (point) (- end beg)))) @@ -520,15 +540,16 @@ 101 5 ??? impossible 110 6 some completion happened 111 7 completed to an exact completion" - (let* ((beg (field-beginning)) - (end (field-end)) - (string (buffer-substring beg end)) - (comp (funcall (or try-completion-function - 'completion-try-completion) - string - minibuffer-completion-table - minibuffer-completion-predicate - (- (point) beg)))) + (lexical-let* + ((beg (field-beginning)) + (end (field-end)) + (string (buffer-substring beg end)) + (comp (funcall (or try-completion-function + 'completion-try-completion) + string + minibuffer-completion-table + minibuffer-completion-predicate + (- (point) beg)))) (cond ((null comp) (minibuffer-hide-completions) @@ -541,14 +562,15 @@ ;; `completed' should be t if some completion was done, which doesn't ;; include simply changing the case of the entered string. However, ;; for appearance, the string is rewritten if the case changes. - (let* ((comp-pos (cdr comp)) - (completion (car comp)) - (completed (not (eq t (compare-strings completion nil nil - string nil nil t)))) - (unchanged (eq t (compare-strings completion nil nil - string nil nil nil)))) + (lexical-let* + ((comp-pos (cdr comp)) + (completion (car comp)) + (completed (not (eq t (compare-strings completion nil nil + string nil nil t)))) + (unchanged (eq t (compare-strings completion nil nil + string nil nil nil)))) (if unchanged - (goto-char end) + (goto-char end) ;; Insert in minibuffer the chars we got. (completion--replace beg end completion)) ;; Move point to its completion-mandated destination. @@ -729,8 +751,8 @@ `minibuffer-confirm-exit-commands', and accept the input otherwise." (interactive) - (let ((beg (field-beginning)) - (end (field-end))) + (lexical-let ((beg (field-beginning)) + (end (field-end))) (cond ;; Allow user to specify null string ((= beg end) (exit-minibuffer)) @@ -1107,14 +1129,13 @@ "Display a list of possible completions of the current minibuffer contents." (interactive) (message "Making completion list...") - (let* ((non-essential t) - (start (field-beginning)) - (string (field-string)) - (completions (completion-all-completions - string - minibuffer-completion-table - minibuffer-completion-predicate - (- (point) (field-beginning))))) + (lexical-let* ((start (field-beginning)) + (string (field-string)) + (completions (completion-all-completions + string + minibuffer-completion-table + minibuffer-completion-predicate + (- (point) (field-beginning))))) (message nil) (if (and completions (or (consp (cdr completions)) @@ -1767,9 +1788,10 @@ (substring afterpoint 0 (cdr bounds))))) (defun completion-basic-try-completion (string table pred point) - (let* ((beforepoint (substring string 0 point)) - (afterpoint (substring string point)) - (bounds (completion-boundaries beforepoint table pred afterpoint))) + (lexical-let* + ((beforepoint (substring string 0 point)) + (afterpoint (substring string point)) + (bounds (completion-boundaries beforepoint table pred afterpoint))) (if (zerop (cdr bounds)) ;; `try-completion' may return a subtly different result ;; than `all+merge', so try to use it whenever possible. @@ -1780,22 +1802,30 @@ (concat completion (completion--merge-suffix completion point afterpoint)) (length completion)))) - (let* ((suffix (substring afterpoint (cdr bounds))) - (prefix (substring beforepoint 0 (car bounds))) - (pattern (completion-basic--pattern - beforepoint afterpoint bounds)) - (all (completion-pcm--all-completions prefix pattern table pred))) + (lexical-let* + ((suffix (substring afterpoint (cdr bounds))) + (prefix (substring beforepoint 0 (car bounds))) + (pattern (delete + "" (list (substring beforepoint (car bounds)) + 'point + (substring afterpoint 0 (cdr bounds))))) + (all (completion-pcm--all-completions prefix pattern table pred))) (if minibuffer-completing-file-name (setq all (completion-pcm--filename-try-filter all))) (completion-pcm--merge-try pattern all prefix suffix))))) (defun completion-basic-all-completions (string table pred point) - (let* ((beforepoint (substring string 0 point)) - (afterpoint (substring string point)) - (bounds (completion-boundaries beforepoint table pred afterpoint)) - (prefix (substring beforepoint 0 (car bounds))) - (pattern (completion-basic--pattern beforepoint afterpoint bounds)) - (all (completion-pcm--all-completions prefix pattern table pred))) + (lexical-let* + ((beforepoint (substring string 0 point)) + (afterpoint (substring string point)) + (bounds (completion-boundaries beforepoint table pred afterpoint)) + (suffix (substring afterpoint (cdr bounds))) + (prefix (substring beforepoint 0 (car bounds))) + (pattern (delete + "" (list (substring beforepoint (car bounds)) + 'point + (substring afterpoint 0 (cdr bounds))))) + (all (completion-pcm--all-completions prefix pattern table pred))) (completion-hilit-commonality all point (car bounds)))) ;;; Partial-completion-mode style completion. @@ -1958,12 +1988,13 @@ FILTER is a function applied to the return value, that can be used, e.g. to filter out additional entries (because TABLE migth not obey PRED)." (unless filter (setq filter 'identity)) - (let* ((beforepoint (substring string 0 point)) - (afterpoint (substring string point)) - (bounds (completion-boundaries beforepoint table pred afterpoint)) - (prefix (substring beforepoint 0 (car bounds))) - (suffix (substring afterpoint (cdr bounds))) - firsterror) + (lexical-let* + ((beforepoint (substring string 0 point)) + (afterpoint (substring string point)) + (bounds (completion-boundaries beforepoint table pred afterpoint)) + (prefix (substring beforepoint 0 (car bounds))) + (suffix (substring afterpoint (cdr bounds))) + firsterror) (setq string (substring string (car bounds) (+ point (cdr bounds)))) (let* ((relpoint (- point (car bounds))) (pattern (completion-pcm--string->pattern string relpoint))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/cl-compat.el Fri Oct 08 12:14:47 2010 +0200 @@ -0,0 +1,200 @@ +;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) + +;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Version: 2.02 +;; Keywords: extensions +;; Obsolete-since: 23.3 + +;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file has been obsolete since Emacs 23.3. + +;; 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 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: + +;; This used to be: +;; (or (featurep 'cl) (require 'cl)) +;; which just has the effect of fooling the byte-compiler into not +;; loading cl when compiling. However, that leads to some bogus +;; compiler warnings. Loading cl when compiling cannot do any harm, +;; because for a long time bootstrap-emacs contained 'cl, due to being +;; dumped from uncompiled files that eval-when-compile'd cl. So every +;; file was compiled with 'cl loaded. +(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 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. + +(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) + (declare (indent 1)) + (list 'apply function + (cons 'append + (mapcar (function (lambda (x) (list 'Multiple-value-list x))) + args)))) + +(defmacro Multiple-value-bind (vars form &rest body) + (declare (indent 2)) + (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) + +(defmacro Multiple-value-setq (vars form) + (declare (indent 2)) + (list 'multiple-value-setq vars (list 'Multiple-value-list form))) + +(defmacro Multiple-value-prog1 (form &rest body) + (declare (indent 1)) + (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 (lambda (x) (make-symbol "--cl-var--")) 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) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: + +;;; cl-compat.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/lmenu.el Fri Oct 08 12:14:47 2010 +0200 @@ -0,0 +1,445 @@ +;;; lmenu.el --- emulate Lucid's menubar support + +;; Copyright (C) 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Keywords: emulations obsolete +;; Obsolete-since: 23.3 + +;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file has been obsolete since Emacs 23.3. + +;;; Code: + + +;; First, emulate the Lucid menubar support in GNU Emacs 19. + +;; Arrange to use current-menubar to set up part of the menu bar. + +(defvar current-menubar) +(defvar lucid-menubar-map) +(defvar lucid-failing-menubar) + +(defvar recompute-lucid-menubar 'recompute-lucid-menubar) +(defun recompute-lucid-menubar () + (define-key lucid-menubar-map [menu-bar] + (condition-case nil + (make-lucid-menu-keymap "menu-bar" current-menubar) + (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") + (sit-for 1) + (setq lucid-failing-menubar current-menubar + current-menubar nil)))) + (setq lucid-menu-bar-dirty-flag nil)) + +(defvar lucid-menubar-map (make-sparse-keymap)) +(or (assq 'current-menubar minor-mode-map-alist) + (setq minor-mode-map-alist + (cons (cons 'current-menubar lucid-menubar-map) + minor-mode-map-alist))) + +;; XEmacs compatibility +(defun set-menubar-dirty-flag () + (force-mode-line-update) + (setq lucid-menu-bar-dirty-flag t)) + +(defvar add-menu-item-count 0) + +;; This is a variable whose value is always nil. +(defvar make-lucid-menu-keymap-disable nil) + +;; Return a menu keymap corresponding to a Lucid-style menu list +;; MENU-ITEMS, and with name MENU-NAME. +(defun make-lucid-menu-keymap (menu-name menu-items) + (let ((menu (make-sparse-keymap menu-name))) + ;; Process items in reverse order, + ;; since the define-key loop reverses them again. + (setq menu-items (reverse menu-items)) + (while menu-items + (let ((item (car menu-items)) + command name callback) + (cond ((stringp item) + (setq command nil) + (setq name (if (string-match "^-+$" item) "" item))) + ((consp item) + (setq command (make-lucid-menu-keymap (car item) (cdr item))) + (setq name (car item))) + ((vectorp item) + (setq command (make-symbol (format "menu-function-%d" + add-menu-item-count)) + add-menu-item-count (1+ add-menu-item-count) + name (aref item 0) + callback (aref item 1)) + (if (symbolp callback) + (fset command callback) + (fset command (list 'lambda () '(interactive) callback))) + (put command 'menu-alias t) + (let ((i 2)) + (while (< i (length item)) + (cond + ((eq (aref item i) ':active) + (put command 'menu-enable + (or (aref item (1+ i)) + 'make-lucid-menu-keymap-disable)) + (setq i (+ 2 i))) + ((eq (aref item i) ':suffix) + ;; unimplemented + (setq i (+ 2 i))) + ((eq (aref item i) ':keys) + ;; unimplemented + (setq i (+ 2 i))) + ((eq (aref item i) ':style) + ;; unimplemented + (setq i (+ 2 i))) + ((eq (aref item i) ':selected) + ;; unimplemented + (setq i (+ 2 i))) + ((and (symbolp (aref item i)) + (= ?: (string-to-char (symbol-name (aref item i))))) + (error "Unrecognized menu item keyword: %S" + (aref item i))) + ((= i 2) + ;; old-style format: active-p &optional suffix + (put command 'menu-enable + (or (aref item i) 'make-lucid-menu-keymap-disable)) + ;; suffix is unimplemented + (setq i (length item))) + (t + (error "Unexpected menu item value: %S" + (aref item i)))))))) + (if (null command) + ;; Handle inactive strings specially--allow any number + ;; of identical ones. + (setcdr menu (cons (list nil name) (cdr menu))) + (if name + (define-key menu (vector (intern name)) (cons name command))))) + (setq menu-items (cdr menu-items))) + menu)) + +(declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) + +;; XEmacs compatibility function +(defun popup-dialog-box (data) + "Pop up a dialog box. +A dialog box description is a list. + + - The first element of the list is a string to display in the dialog box. + - The rest of the elements are descriptions of the dialog box's buttons. + Each one is a vector of three elements: + - The first element is the text of the button. + - The second element is the `callback'. + - The third element is t or nil, whether this button is selectable. + +If the `callback' of a button is a symbol, then it must name a command. +It will be invoked with `call-interactively'. If it is a list, then it is +evaluated with `eval'. + +One (and only one) of the buttons may be nil. This marker means that all +following buttons should be flushright instead of flushleft. + +The syntax, more precisely: + + form := <something to pass to `eval'> + command := <a symbol or string, to pass to `call-interactively'> + callback := command | form + active-p := <t, nil, or a form to evaluate to decide whether this + button should be selectable> + name := <string> + partition := 'nil' + button := '[' name callback active-p ']' + dialog := '(' name [ button ]+ [ partition [ button ]+ ] ')'" + (let ((name (car data)) + (tail (cdr data)) + converted + choice meaning) + (while tail + (if (null (car tail)) + (setq converted (cons nil converted)) + (let ((item (aref (car tail) 0)) + (callback (aref (car tail) 1)) + (enable (aref (car tail) 2))) + (setq converted + (cons (if enable (cons item callback) item) + converted)))) + (setq tail (cdr tail))) + (setq choice (x-popup-dialog t (cons name (nreverse converted)))) + (if choice + (if (symbolp choice) + (call-interactively choice) + (eval choice))))) + +;; This is empty because the usual elements of the menu bar +;; are provided by menu-bar.el instead. +;; It would not make sense to duplicate them here. +(defconst default-menubar nil) + +;; XEmacs compatibility +(defun set-menubar (menubar) + "Set the default menubar to be menubar." + (setq-default current-menubar (copy-sequence menubar)) + (set-menubar-dirty-flag)) + +;; XEmacs compatibility +(defun set-buffer-menubar (menubar) + "Set the buffer-local menubar to be menubar." + (make-local-variable 'current-menubar) + (setq current-menubar (copy-sequence menubar)) + (set-menubar-dirty-flag)) + + +;;; menu manipulation functions + +;; XEmacs compatibility +(defun find-menu-item (menubar item-path-list &optional parent) + "Searches MENUBAR for item given by ITEM-PATH-LIST. +Returns (ITEM . PARENT), where PARENT is the immediate parent of + the item found. +Signals an error if the item is not found." + (or parent (setq item-path-list (mapcar 'downcase item-path-list))) + (if (not (consp menubar)) + nil + (let ((rest menubar) + result) + (while rest + (if (and (car rest) + (equal (car item-path-list) + (downcase (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 "not a submenu" result)) + (signal 'error (list "no such submenu" (car item-path-list))))) + (cons result parent))))) + + +;; XEmacs compatibility +(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\"." + (let* ((menubar current-menubar) + (pair (find-menu-item menubar path)) + (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 "can't disable menus, only menu items")) + (aset item 2 nil) + (set-menubar-dirty-flag) + item)) + + +;; XEmacs compatibility +(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\"." + (let* ((menubar current-menubar) + (pair (find-menu-item menubar path)) + (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)) + (aset item 2 t) + (set-menubar-dirty-flag) + item)) + + +(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) + (if before (setq before (downcase before))) + (let* ((menubar current-menubar) + (menu (condition-case () + (car (find-menu-item menubar menu-path)) + (error nil))) + (item (if (listp menu) + (car (find-menu-item (cdr menu) (list item-name))) + (signal 'error (list "not a submenu" menu-path))))) + (or 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)))))) + (or menu + (let ((rest2 so-far)) + (or rest2 + (error "Trying to modify a menu that doesn't exist")) + (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))))) + (or menu (setq menu menubar)) + (if item + nil ; it's already there + (if item-p + (setq item (vector item-name item-data enabled-p)) + (setq item (cons item-name item-data))) + ;; if BEFORE is specified, try to add it there. + (if 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 item (cdr rest))) + (setq rest nil added-before t)) + (setq rest (cdr rest)))) + (if (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 item menu) + current-menubar menu) + ;; otherwise, add the item to the end. + (nconc menu (list item)))))) + (if item-p + (progn + (aset item 1 item-data) + (aset item 2 (not (null enabled-p)))) + (setcar item item-name) + (setcdr item item-data)) + (set-menubar-dirty-flag) + item)) + +;; XEmacs compatibility +(defun add-menu-item (menu-path item-name function enabled-p &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\". +ITEM-NAME is the string naming the menu item to be added. +FUNCTION is the command to invoke when this menu item is selected. + If it is a symbol, then it is invoked with `call-interactively', in the same + way that functions bound to keys are invoked. If it is a list, then the + list is simply evaluated. +ENABLED-P controls whether the item is selectable or not. +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." + (or menu-path (error "must specify a menu path")) + (or item-name (error "must specify an item name")) + (add-menu-item-1 t menu-path item-name function enabled-p before)) + + +;; XEmacs compatibility +(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. (\"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\"." + (let* ((menubar current-menubar) + (pair (find-menu-item menubar path)) + (item (car pair)) + (menu (or (cdr pair) menubar))) + (if (not item) + nil + ;; the menubar is the only special case, because other menus begin + ;; with their name. + (if (eq menu current-menubar) + (setq current-menubar (delq item menu)) + (delq item menu)) + (set-menubar-dirty-flag) + item))) + + +;; XEmacs compatibility +(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 "No such menu item" "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)) + +;; XEmacs compatibility +(defun add-menu (menu-path menu-name menu-items &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. +MENU-NAME is the string naming the menu to be added. +MENU-ITEMS is a list of menu item descriptions. + Each menu item should be a vector of three elements: + - a string, the name of the menu item; + - a symbol naming a command, or a form to evaluate; + - and a form whose value determines whether this item is selectable. +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." + (or menu-name (error "must specify a menu name")) + (or menu-items (error "must specify some menu items")) + (add-menu-item-1 nil menu-path menu-name menu-items t before)) + + + +(defvar put-buffer-names-in-file-menu t) + + +;; Don't unconditionally enable menu bars; leave that up to the user. +;;(let ((frames (frame-list))) +;; (while frames +;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) +;; (setq frames (cdr frames)))) +;;(or (assq 'menu-bar-lines default-frame-alist) +;; (setq default-frame-alist +;; (cons '(menu-bar-lines . 1) default-frame-alist))) + +(set-menubar default-menubar) + +(provide 'lmenu) + +;;; lmenu.el ends here
--- a/lisp/server.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/server.el Fri Oct 08 12:14:47 2010 +0200 @@ -859,7 +859,7 @@ returned by -eval. `-error DESCRIPTION' - Signal an error (but continue processing). + Signal an error and delete process PROC. `-suspend' Suspend this terminal, i.e., stop the client process.
--- a/lisp/vc/vc-svn.el Fri Oct 08 00:51:19 2010 -0700 +++ b/lisp/vc/vc-svn.el Fri Oct 08 12:14:47 2010 +0200 @@ -374,7 +374,7 @@ (message "Merging changes into %s..." file) ;; (vc-file-setprop file 'vc-working-revision nil) (vc-file-setprop file 'vc-checkout-time 0) - (vc-svn-command nil 0 file "update") + (vc-svn-command nil 0 file "--non-interactive" "update") ; see bug#7152 ;; Analyze the merge result reported by SVN, and set ;; file properties accordingly. (with-current-buffer (get-buffer "*vc*")
--- a/src/ChangeLog Fri Oct 08 00:51:19 2010 -0700 +++ b/src/ChangeLog Fri Oct 08 12:14:47 2010 +0200 @@ -1,3 +1,54 @@ +2010-10-08 Kenichi Handa <handa@m17n.org> + + * coding.c (complement_process_encoding_system): Fix previous change. + +2010-10-08 Michael Albinus <michael.albinus@gmx.de> + + * dbusbind.c (syms_of_dbusbind): Move putenv call ... + (Fdbus_init_bus): ... here. (Bug#7113) + +2010-10-08 Glenn Morris <rgm@gnu.org> + + * buffer.c (before-change-functions, after-change-functions): + Three-year overdue doc fix following 2007-08-13 change. + +2010-10-08 Kenichi Handa <handa@m17n.org> + + * coding.c (coding_inherit_eol_type): If parent doesn't specify + eol-format, inherit from the system's default. + (complement_process_encoding_system): Make a new coding system + inherit the original eol-format. + +2010-10-08 Kenichi Handa <handa@m17n.org> + + * coding.c (complement_process_encoding_system): New function. + + * coding.h (complement_process_encoding_system): Extern it. + + * callproc.c (Fcall_process): Complement the coding system for + encoding arguments. + (Fcall_process_region): Complement the coding system for encoding + the input to the process. + + * process.c (Fstart_process): Complement the coding system for + encoding arguments. + (send_process): Complement the coding system for encoding what + sent to the process. + +2010-10-08 Kenichi Handa <handa@m17n.org> + + * xfont.c (xfont_open): Fix setting of font->average_width from + :avgwidth property (Bug#7123). + +2010-10-08 Michael Albinus <michael.albinus@gmx.de> + + * dbusbind.c (syms_of_dbusbind): Use putenv instead of setenv, it + is more portable. + + * keyboard.c (gobble_input): Move call of xd_read_queued_messages ... + (kbd_buffer_get_event): ... here. This is needed for cygwin, which + has not defined SIGIO. + 2010-10-08 Chong Yidong <cyd@stupidchicken.com> * xterm.c (x_draw_relief_rect): If box width is larger than 1,
--- a/src/buffer.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/buffer.c Fri Oct 08 12:14:47 2010 +0200 @@ -5957,10 +5957,7 @@ Buffer changes made while executing the `before-change-functions' don't call any before-change or after-change functions. -That's because these variables are temporarily set to nil. -As a result, a hook function cannot straightforwardly alter the -value of these variables. See the Emacs Lisp manual for a way of -accomplishing an equivalent result by using other variables. +That's because `inhibit-modification-hooks' is temporarily set non-nil. If an unhandled error happens in running these functions, the variable's value remains nil. That prevents the error @@ -5978,10 +5975,7 @@ Buffer changes made while executing the `after-change-functions' don't call any before-change or after-change functions. -That's because these variables are temporarily set to nil. -As a result, a hook function cannot straightforwardly alter the -value of these variables. See the Emacs Lisp manual for a way of -accomplishing an equivalent result by using other variables. +That's because `inhibit-modification-hooks' is temporarily set non-nil. If an unhandled error happens in running these functions, the variable's value remains nil. That prevents the error
--- a/src/callproc.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/callproc.c Fri Oct 08 12:14:47 2010 +0200 @@ -254,21 +254,16 @@ if (!NILP (Vcoding_system_for_write)) val = Vcoding_system_for_write; else if (! must_encode) - val = Qnil; + val = Qraw_text; else { args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof *args2); args2[0] = Qcall_process; for (i = 0; i < nargs; i++) args2[i + 1] = args[i]; coding_systems = Ffind_operation_coding_system (nargs + 1, args2); - if (CONSP (coding_systems)) - val = XCDR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCDR (Vdefault_process_coding_system); - else - val = Qnil; + val = CONSP (coding_systems) ? XCDR (coding_systems) : Qnil; } - val = coding_inherit_eol_type (val, Qnil); + val = complement_process_encoding_system (val); setup_coding_system (Fcheck_coding_system (val), &argument_coding); coding_attrs = CODING_ID_ATTRS (argument_coding.id); if (NILP (CODING_ATTR_ASCII_COMPAT (coding_attrs))) @@ -912,20 +907,16 @@ if (!NILP (Vcoding_system_for_write)) val = Vcoding_system_for_write; else if (NILP (current_buffer->enable_multibyte_characters)) - val = Qnil; + val = Qraw_text; else { args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof *args2); args2[0] = Qcall_process_region; for (i = 0; i < nargs; i++) args2[i + 1] = args[i]; coding_systems = Ffind_operation_coding_system (nargs + 1, args2); - if (CONSP (coding_systems)) - val = XCDR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCDR (Vdefault_process_coding_system); - else - val = Qnil; + val = CONSP (coding_systems) ? XCDR (coding_systems) : Qnil; } + val = complement_process_encoding_system (val); { int count1 = SPECPDL_INDEX ();
--- a/src/coding.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/coding.c Fri Oct 08 12:14:47 2010 +0200 @@ -6016,10 +6016,9 @@ } -/* If CODING_SYSTEM doesn't specify end-of-line format but PARENT - does, return one of the subsidiary that has the same eol-spec as - PARENT. Otherwise, return CODING_SYSTEM. If PARENT is nil, - inherit end-of-line format from the system's setting +/* If CODING_SYSTEM doesn't specify end-of-line format, return one of + the subsidiary that has the same eol-spec as PARENT (if it is not + nil and specifies end-of-line format) or the system's setting (system_eol_type). */ Lisp_Object @@ -6041,6 +6040,8 @@ parent_spec = CODING_SYSTEM_SPEC (parent); parent_eol_type = AREF (parent_spec, 2); + if (VECTORP (parent_eol_type)) + parent_eol_type = system_eol_type; } else parent_eol_type = system_eol_type; @@ -6054,6 +6055,45 @@ return coding_system; } + +/* Check if text-conversion and eol-conversion of CODING_SYSTEM are + decided for writing to a process. If not, complement them, and + return a new coding system. */ + +Lisp_Object +complement_process_encoding_system (Lisp_Object coding_system) +{ + Lisp_Object coding_base = Qnil, eol_base = Qnil; + Lisp_Object spec, attrs; + int i; + + for (i = 0; i < 3; i++) + { + if (i == 1) + coding_system = CDR_SAFE (Vdefault_process_coding_system); + else if (i == 2) + coding_system = preferred_coding_system (); + spec = CODING_SYSTEM_SPEC (coding_system); + if (NILP (spec)) + continue; + attrs = AREF (spec, 0); + if (NILP (coding_base) && ! EQ (CODING_ATTR_TYPE (attrs), Qundecided)) + coding_base = CODING_ATTR_BASE_NAME (attrs); + if (NILP (eol_base) && ! VECTORP (AREF (spec, 2))) + eol_base = coding_system; + if (! NILP (coding_base) && ! NILP (eol_base)) + break; + } + + if (i > 0) + /* The original CODING_SYSTEM didn't specify text-conversion or + eol-conversion. Be sure that we return a fully complemented + coding system. */ + coding_system = coding_inherit_eol_type (coding_base, eol_base); + return coding_system; +} + + /* Emacs has a mechanism to automatically detect a coding system if it is one of Emacs' internal format, ISO2022, SJIS, and BIG5. But, it's impossible to distinguish some coding systems accurately
--- a/src/coding.h Fri Oct 08 00:51:19 2010 -0700 +++ b/src/coding.h Fri Oct 08 12:14:47 2010 +0200 @@ -707,6 +707,7 @@ int); extern Lisp_Object raw_text_coding_system (Lisp_Object); extern Lisp_Object coding_inherit_eol_type (Lisp_Object, Lisp_Object); +extern Lisp_Object complement_process_encoding_system (Lisp_Object); extern int decode_coding_gap (struct coding_system *, EMACS_INT, EMACS_INT);
--- a/src/dbusbind.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/dbusbind.c Fri Oct 08 12:14:47 2010 +0200 @@ -900,6 +900,9 @@ /* Add bus to list of registered buses. */ Vdbus_registered_buses = Fcons (bus, Vdbus_registered_buses); + /* We do not want to abort. */ + putenv ("DBUS_FATAL_WARNINGS=0"); + /* Return. */ return Qnil; } @@ -2160,12 +2163,11 @@ doc: /* If non-nil, debug messages of D-Bus bindings are raised. */); #ifdef DBUS_DEBUG Vdbus_debug = Qt; - /* We can also set environment DBUS_VERBOSE=1 in order to see more - traces. */ + /* We can also set environment variable DBUS_VERBOSE=1 in order to + see more traces. This requires libdbus-1 to be configured with + --enable-verbose-mode. */ #else Vdbus_debug = Qnil; - /* We do not want to abort. */ - setenv ("DBUS_FATAL_WARNINGS", "0", 1); #endif Fprovide (intern_c_string ("dbusbind"), Qnil);
--- a/src/keyboard.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/keyboard.c Fri Oct 08 12:14:47 2010 +0200 @@ -3952,6 +3952,11 @@ /* One way or another, wait until input is available; then, if interrupt handlers have not read it, read it now. */ +#ifdef HAVE_DBUS + /* Read D-Bus messages. */ + xd_read_queued_messages (); +#endif /* HAVE_DBUS */ + /* Note SIGIO has been undef'd if FIONREAD is missing. */ #ifdef SIGIO gobble_input (0);
--- a/src/process.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/process.c Fri Oct 08 12:14:47 2010 +0200 @@ -1670,6 +1670,11 @@ val = XCDR (Vdefault_process_coding_system); } XPROCESS (proc)->encode_coding_system = val; + /* Note: At this momemnt, the above coding system may leave + text-conversion or eol-conversion unspecified. They will be + decided after we read output from the process and decode it by + some coding system, or just before we actually send a text to + the process. */ } @@ -1712,6 +1717,7 @@ tem = Fsubstring (tem, make_number (2), Qnil); { + Lisp_Object arg_encoding = Qnil; struct gcpro gcpro1; GCPRO1 (tem); @@ -1729,9 +1735,14 @@ tem = Fcons (args[i], tem); CHECK_STRING (XCAR (tem)); if (STRING_MULTIBYTE (XCAR (tem))) - XSETCAR (tem, - code_convert_string_norecord - (XCAR (tem), XPROCESS (proc)->encode_coding_system, 1)); + { + if (NILP (arg_encoding)) + arg_encoding = (complement_process_encoding_system + (XPROCESS (proc)->encode_coding_system)); + XSETCAR (tem, + code_convert_string_norecord + (XCAR (tem), arg_encoding, 1)); + } } UNGCPRO; @@ -5529,12 +5540,21 @@ && !NILP (XBUFFER (object)->enable_multibyte_characters)) || EQ (object, Qt)) { + p->encode_coding_system + = complement_process_encoding_system (p->encode_coding_system); if (!EQ (Vlast_coding_system_used, p->encode_coding_system)) - /* The coding system for encoding was changed to raw-text - because we sent a unibyte text previously. Now we are - sending a multibyte text, thus we must encode it by the - original coding system specified for the current process. */ - setup_coding_system (p->encode_coding_system, coding); + { + /* The coding system for encoding was changed to raw-text + because we sent a unibyte text previously. Now we are + sending a multibyte text, thus we must encode it by the + original coding system specified for the current process. + + Another reason we comming here is that the coding system + was just complemented and new one was returned by + complement_process_encoding_system. */ + setup_coding_system (p->encode_coding_system, coding); + Vlast_coding_system_used = p->encode_coding_system; + } coding->src_multibyte = 1; } else
--- a/src/xfont.c Fri Oct 08 00:51:19 2010 -0700 +++ b/src/xfont.c Fri Oct 08 12:14:47 2010 +0200 @@ -841,7 +841,7 @@ val = Ffont_get (font_object, QCavgwidth); if (INTEGERP (val)) - font->average_width = XINT (val); + font->average_width = XINT (val) / 10; if (font->average_width < 0) font->average_width = - font->average_width; if (font->average_width == 0