Merge from trunk.

9 files changed, 505 insertions, 49 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 87de0957574..780ec1001ff 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,9 @@
 2011-07-01  Paul Eggert  <eggert@cs.ucla.edu>
 
+	Time-stamp simplifications and fixes.
+	These improve accuracy slightly, and future-proof the code
+	against some potential changes to current-time format.
+
 	* woman.el (woman-decode-buffer, WoMan-log-end): Log fractional secs
 	by using time-since and float-time.
 
@@ -25,6 +29,27 @@
 	* emacs-lisp/benchmark.el (benchmark-elapse):
 	* allout-widgets.el (allout-elapsed-time-seconds): Use float-time.
 
+2011-07-01  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	* window.el (bury-buffer): Don't iconify the only frame.
+	(switch-to-buffer): Revert to Emacs<23 behavior, i.e. do not fallback
+	to pop-to-buffer.  Use pop-to-buffer-same-frame if you don't like that.
+
+2011-07-01  Chong Yidong  <cyd@stupidchicken.com>
+
+	* eshell/em-smart.el (eshell-smart-display-navigate-list):
+	Add mouse-yank-primary.
+
+2011-07-01  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* progmodes/cfengine3.el: New file to support CFEngine 3.x.
+
+2011-07-01  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	* emacs-lisp/find-func.el (find-library--load-name): New fun.
+	(find-library-name): Use it to find relative load names when provided
+	absolute file name (bug#8803).
+
 2011-06-30  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
 	* textmodes/flyspell.el (flyspell-word): Consider words that
@@ -41,7 +66,7 @@
 
 	* progmodes/cc-guess.el: New file.
 
-	* progmodes/cc-langs.el (c-mode-menu): Added "Style..." submenu.
+	* progmodes/cc-langs.el (c-mode-menu): Add "Style..." submenu.
 
 	* progmodes/cc-styles.el (cc-choose-style-for-mode): New function
 	derived from `c-basic-common-init'.
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 9c4a3e9832c..0194af2e3a8 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -141,6 +141,15 @@ See the functions `find-function' and `find-variable'."
     (dolist (suffix (get-load-suffixes) (nreverse suffixes))
       (unless (string-match "elc" suffix) (push suffix suffixes)))))
 
+(defun find-library--load-name (library)
+  (let ((name library))
+    (dolist (dir load-path)
+      (let ((rel (file-relative-name library dir)))
+        (if (and (not (string-match "\\`\\.\\./" rel))
+                 (< (length rel) (length name)))
+            (setq name rel))))
+    (unless (equal name library) name)))
+
 (defun find-library-name (library)
   "Return the absolute file name of the Emacs Lisp source of LIBRARY.
 LIBRARY should be a string (the name of the library)."
@@ -148,13 +157,23 @@ LIBRARY should be a string (the name of the library)."
   ;; the same name.
   (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
       (setq library (replace-match "" t t library)))
-  (or 
+  (or
    (locate-file library
 		(or find-function-source-path load-path)
 		(find-library-suffixes))
    (locate-file library
 		(or find-function-source-path load-path)
 		load-file-rep-suffixes)
+   (when (file-name-absolute-p library)
+     (let ((rel (find-library--load-name library)))
+       (when rel
+         (or
+          (locate-file rel
+                       (or find-function-source-path load-path)
+                       (find-library-suffixes))
+          (locate-file rel
+                       (or find-function-source-path load-path)
+                       load-file-rep-suffixes)))))
    (error "Can't find library %s" library)))
 
 (defvar find-function-C-source-directory
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index f08fec8f8fa..259072d9750 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -120,6 +120,7 @@ only if that output can be presented in its entirely in the Eshell window."
 (defcustom eshell-smart-display-navigate-list
   '(insert-parentheses
     mouse-yank-at-click
+    mouse-yank-primary
     mouse-yank-secondary
     yank-pop
     yank-rectangle
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 88ba910912e..7d1e7ed7198 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -3,7 +3,24 @@
 	* nntp.el (nntp-record-command):
 	* gnus-util.el (gnus-message-with-timestamp-1):
 	Use format-time-string rather than decoding time stamps by hand.
-	This is simpler and insulates the code from changes to time formats.
+	This is simpler and insulates the code from potential changes to
+	current-time format.
+
+2011-07-01  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+	* gnus-draft.el (gnus-draft-clear-marks): Mark deleted articles as read.
+
+2011-07-01  Daiki Ueno  <ueno@unixuser.org>
+
+	* plstore.el (plstore-select-keys, plstore-encrypt-to): New variable.
+	(plstore-save): Support public key encryption.
+	(plstore--init-from-buffer): New function.
+	(plstore-open): Use it; fix error when opening a non-existent file.
+	(plstore-revert): Use plstore--init-from-buffer.
+
+2011-07-01  Daiki Ueno  <ueno@unixuser.org>
+
+	* auth-source.el (auth-source-backend): Fix :initarg for data slot.
 
 2011-06-30  Katsumi Yamaoka  <yamaoka@jpl.org>
 
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 9391bf23d37..9d62d6a81c4 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -116,7 +116,7 @@ let-binding."
          :type t
          :custom string
          :documentation "The backend protocol.")
-   (data :initarg :arg
+   (data :initarg :data
          :initform nil
          :documentation "Internal backend data.")
    (create-function :initarg :create-function
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 1709b1c4a05..a2a4cd3e07d 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -325,10 +325,18 @@ If DONT-POP is nil, display the buffer after setting it up."
 	(error "The draft %s is under edit" file)))))
 
 (defun gnus-draft-clear-marks ()
-  (setq gnus-newsgroup-reads nil
-	gnus-newsgroup-marked nil
-	gnus-newsgroup-unreads
-	(gnus-uncompress-range (gnus-active gnus-newsgroup-name))))
+  (setq gnus-newsgroup-marked nil
+	gnus-newsgroup-unreads (gnus-uncompress-range
+				(gnus-active gnus-newsgroup-name)))
+  ;; Mark articles except for deleted ones as unread.
+  (let (rest)
+    (dolist (article gnus-newsgroup-reads)
+      (when (and (consp article)
+		 (eq (cdr article) gnus-canceled-mark))
+	(push article rest)
+	(setq gnus-newsgroup-unreads
+	      (delq (car article) gnus-newsgroup-unreads))))
+    (setq gnus-newsgroup-reads (nreverse rest))))
 
 (provide 'gnus-draft)
 
diff --git a/lisp/gnus/plstore.el b/lisp/gnus/plstore.el
index 392437d1dea..360388d002e 100644
--- a/lisp/gnus/plstore.el
+++ b/lisp/gnus/plstore.el
@@ -44,6 +44,40 @@
 
 (require 'epg)
 
+(defgroup plstore nil
+  "Searchable, partially encrypted, persistent plist store"
+  :version "24.1"
+  :group 'files)
+
+(defcustom plstore-select-keys 'silent
+  "Control whether or not to pop up the key selection dialog.
+
+If t, always asks user to select recipients.
+If nil, query user only when `plstore-encrypt-to' is not set.
+If neither t nor nil, doesn't ask user.  In this case, symmetric
+encryption is used."
+  :type '(choice (const :tag "Ask always" t)
+		 (const :tag "Ask when recipients are not set" nil)
+		 (const :tag "Don't ask" silent))
+  :group 'plstore)
+
+(defvar plstore-encrypt-to nil
+  "*Recipient(s) used for encrypting secret entries.
+May either be a string or a list of strings.")
+
+(put 'plstore-encrypt-to 'safe-local-variable
+     (lambda (val)
+       (or (stringp val)
+	   (and (listp val)
+		(catch 'safe
+		  (mapc (lambda (elt)
+			  (unless (stringp elt)
+			    (throw 'safe nil)))
+			val)
+		  t)))))
+
+(put 'plstore-encrypt-to 'permanent-local t)
+
 (defvar plstore-cache-passphrase-for-symmetric-encryption nil)
 (defvar plstore-passphrase-alist nil)
 
@@ -107,35 +141,39 @@
 (defun plstore-get-file (this)
   (buffer-file-name (plstore--get-buffer this)))
 
+(defun plstore--init-from-buffer (plstore)
+  (goto-char (point-min))
+  (when (looking-at ";;; public entries")
+    (forward-line)
+    (plstore--set-alist plstore (read (point-marker)))
+    (forward-sexp)
+    (forward-char)
+    (when (looking-at ";;; secret entries")
+      (forward-line)
+      (plstore--set-encrypted-data plstore (read (point-marker))))
+    (plstore--merge-secret plstore)))
+
 ;;;###autoload
 (defun plstore-open (file)
   "Create a plstore instance associated with FILE."
-  (let ((store (vector
-		(find-file-noselect file)
-		nil		     ;plist (plist)
-		nil		     ;encrypted data (string)
-		nil		     ;secret plist (plist)
-		nil		     ;merged plist (plist)
-		)))
-    (plstore-revert store)
-    store))
+  (with-current-buffer (find-file-noselect file)
+    ;; make the buffer invisible from user
+    (rename-buffer (format " plstore %s" (buffer-file-name)))
+    (let ((store (vector
+		  (current-buffer)
+		  nil		     ;plist (plist)
+		  nil		     ;encrypted data (string)
+		  nil		     ;secret plist (plist)
+		  nil		     ;merged plist (plist)
+		  )))
+      (plstore--init-from-buffer store)
+      store)))
 
 (defun plstore-revert (plstore)
   "Replace current data in PLSTORE with the file on disk."
   (with-current-buffer (plstore--get-buffer plstore)
     (revert-buffer t t)
-    ;; make the buffer invisible from user
-    (rename-buffer (format " plstore %s" (buffer-file-name)))
-    (goto-char (point-min))
-    (when (looking-at ";;; public entries\n")
-      (forward-line)
-      (plstore--set-alist plstore (read (point-marker)))
-      (forward-sexp)
-      (forward-char)
-      (when (looking-at ";;; secret entries\n")
-	(forward-line)
-	(plstore--set-encrypted-data plstore (read (point-marker))))
-      (plstore--merge-secret plstore))))
+    (plstore--init-from-buffer plstore)))
 
 (defun plstore-close (plstore)
   "Destroy a plstore instance PLSTORE."
@@ -304,20 +342,37 @@ SECRET-KEYS is a plist containing secret data."
   "Save the contents of PLSTORE associated with a FILE."
   (with-current-buffer (plstore--get-buffer plstore)
     (erase-buffer)
-    (insert ";;; public entries\n" (pp-to-string (plstore--get-alist plstore)))
+    (insert ";;; public entries -*- mode: emacs-lisp -*- \n"
+	    (pp-to-string (plstore--get-alist plstore)))
     (if (plstore--get-secret-alist plstore)
 	(let ((context (epg-make-context 'OpenPGP))
 	      (pp-escape-newlines nil)
+	      (recipients
+	       (cond
+		((listp plstore-encrypt-to) plstore-encrypt-to)
+		((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 	      cipher)
 	  (epg-context-set-armor context t)
 	  (epg-context-set-passphrase-callback
 	   context
 	   (cons #'plstore-passphrase-callback-function
 		 plstore))
-	  (setq cipher (epg-encrypt-string context
-					   (pp-to-string
-					    (plstore--get-secret-alist plstore))
-					   nil))
+	  (setq cipher (epg-encrypt-string
+			context
+			(pp-to-string
+			 (plstore--get-secret-alist plstore))
+			(if (or (eq plstore-select-keys t)
+				(and (null plstore-select-keys)
+				     (not (local-variable-p 'plstore-encrypt-to
+							    (current-buffer)))))
+			    (epa-select-keys
+			     context
+			     "Select recipents for encryption.
+If no one is selected, symmetric encryption will be performed.  "
+			     recipients)
+			  (if plstore-encrypt-to
+			      (epg-list-keys context recipients)))))
+	  (goto-char (point-max))
 	  (insert ";;; secret entries\n" (pp-to-string cipher))))
     (save-buffer)))
 
diff --git a/lisp/progmodes/cfengine3.el b/lisp/progmodes/cfengine3.el
new file mode 100644
index 00000000000..68a4286657c
--- /dev/null
+++ b/lisp/progmodes/cfengine3.el
@@ -0,0 +1,331 @@
+;;; cfengine3.el --- mode for editing Cfengine 3 files
+
+;; Copyright (C) 2001-2011  Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: languages
+
+;; 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:
+
+;; Supports only cfengine 3, unlike the older cfengine.el which
+;; supports 1.x and 2.x.
+
+;; Possible customization for auto-mode selection:
+
+;; (push '(("^cfagent.conf\\'" . cfengine3-mode)) auto-mode-alist)
+;; (push '(("^cf\\." . cfengine3-mode)) auto-mode-alist)
+;; (push '(("\\.cf\\'" . cfengine3-mode)) auto-mode-alist)
+
+;;; Code:
+
+(defgroup cfengine3 ()
+  "Editing CFEngine 3 files."
+  :group 'languages)
+
+(defcustom cfengine3-indent 2
+  "*Size of a CFEngine 3 indentation step in columns."
+  :group 'cfengine3
+  :type 'integer)
+
+(eval-and-compile
+  (defconst cfengine3-defuns
+    (mapcar
+     'symbol-name
+     '(bundle body))
+    "List of the CFEngine 3.x defun headings.")
+
+  (defconst cfengine3-defuns-regex
+    (regexp-opt cfengine3-defuns t)
+    "Regex to match the CFEngine 3.x defuns.")
+
+  (defconst cfengine3-class-selector-regex "\\([[:alnum:]_().&|!]+\\)::")
+
+  (defconst cfengine3-category-regex "\\([[:alnum:]_]+\\):")
+
+  (defconst cfengine3-vartypes
+    (mapcar
+     'symbol-name
+     '(string int real slist ilist rlist irange rrange counter))
+    "List of the CFEngine 3.x variable types."))
+
+(defvar cfengine3-font-lock-keywords
+  `(
+    (,(concat "^[ \t]*" cfengine3-class-selector-regex)
+     1 font-lock-keyword-face)
+    (,(concat "^[ \t]*" cfengine3-category-regex)
+     1 font-lock-builtin-face)
+    ;; Variables, including scope, e.g. module.var
+    ("[@$](\\([[:alnum:]_.]+\\))" 1 font-lock-variable-name-face)
+    ("[@$]{\\([[:alnum:]_.]+\\)}" 1 font-lock-variable-name-face)
+    ;; Variable definitions.
+    ("\\<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
+
+    ;; CFEngine 3.x faces
+    ;; defuns
+    (,(concat "\\<" cfengine3-defuns-regex "\\>"
+              "[ \t]+\\<\\([[:alnum:]_]+\\)\\>"
+              "[ \t]+\\<\\([[:alnum:]_]+\\)\\((\\([^)]*\\))\\)?")
+    (1 font-lock-builtin-face)
+    (2 font-lock-constant-name-face)
+    (3 font-lock-function-name-face)
+    (5 font-lock-variable-name-face))
+    ;; variable types
+    (,(concat "\\<" (eval-when-compile (regexp-opt cfengine3-vartypes t)) "\\>")
+     1 font-lock-type-face)))
+
+(defun cfengine3-beginning-of-defun ()
+  "`beginning-of-defun' function for Cfengine 3 mode.
+Treats body/bundle blocks as defuns."
+  (unless (<= (current-column) (current-indentation))
+    (end-of-line))
+  (if (re-search-backward (concat "^[ \t]*" cfengine3-defuns-regex "\\>") nil t)
+      (beginning-of-line)
+    (goto-char (point-min)))
+  t)
+
+(defun cfengine3-end-of-defun ()
+  "`end-of-defun' function for Cfengine 3 mode.
+Treats body/bundle blocks as defuns."
+  (end-of-line)
+  (if (re-search-forward (concat "^[ \t]*" cfengine3-defuns-regex "\\>") nil t)
+      (beginning-of-line)
+    (goto-char (point-max)))
+  t)
+
+(defun cfengine3-indent-line ()
+  "Indent a line in Cfengine mode.
+Intended as the value of `indent-line-function'."
+  (let ((pos (- (point-max) (point)))
+        parse)
+    (save-restriction
+      (narrow-to-defun)
+      (back-to-indentation)
+      (setq parse (parse-partial-sexp (point-min) (point)))
+      (message "%S" parse)
+      (cond
+       ;; body/bundle blocks start at 0
+       ((looking-at (concat cfengine3-defuns-regex "\\>"))
+        (indent-line-to 0))
+       ;; categories are indented one step
+       ((looking-at (concat cfengine3-category-regex "[ \t]*$"))
+        (indent-line-to cfengine3-indent))
+       ;; class selectors are indented two steps
+       ((looking-at (concat cfengine3-class-selector-regex "[ \t]*$"))
+        (indent-line-to (* 2 cfengine3-indent)))
+       ;; Outdent leading close brackets one step.
+       ((or (eq ?\} (char-after))
+            (eq ?\) (char-after)))
+        (condition-case ()
+            (indent-line-to (save-excursion
+                              (forward-char)
+                              (backward-sexp)
+                              (current-column)))
+          (error nil)))
+       ;; inside a string and it starts before this line
+       ((and (nth 3 parse)
+             (< (nth 8 parse) (save-excursion (beginning-of-line) (point))))
+        (indent-line-to 0))
+       ;; inside a defun, but not a nested list (depth is 1)
+       ((= 1 (nth 0 parse))
+        (indent-line-to (* (+ 2 (nth 0 parse)) cfengine3-indent)))
+       ;; Inside brackets/parens: indent to start column of non-comment
+       ;; token on line following open bracket or by one step from open
+       ;; bracket's column.
+       ((condition-case ()
+            (progn (indent-line-to (save-excursion
+                                     (backward-up-list)
+                                     (forward-char)
+                                     (skip-chars-forward " \t")
+                                     (cond
+                                      ((looking-at "[^\n#]")
+                                       (current-column))
+                                      ((looking-at "[^\n#]")
+                                       (current-column))
+                                      (t
+                                       (skip-chars-backward " \t")
+                                       (+ (current-column) -1
+                                          cfengine3-indent)))))
+                   t)
+          (error nil)))
+       ;; Else don't indent.
+       (t (indent-line-to 0))))
+    ;; 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)))))
+
+;; (defvar cfengine3-smie-grammar
+;;   (smie-prec2->grammar
+;;    (smie-merge-prec2s
+;;    (smie-bnf->prec2
+;;     '((token)
+;;       (decls (decls "body" decls)
+;;              (decls "bundle" decls))
+;;       (insts (token ":" insts)))
+;;     '((assoc "body" "bundle")))
+;;    (smie-precs->prec2
+;;     '((right ":")
+;;       (right "::")
+;;       (assoc ";")
+;;       (assoc ",")
+;;       (right "=>"))))))
+
+;; (defun cfengine3-smie-rules (kind token)
+;;   (pcase (cons kind token)
+;;     (`(:elem . basic) 2)
+;;     (`(:list-intro . ,(or `"body" `"bundle")) t)
+;;     (`(:after . ":") 2)
+;;     (`(:after . "::") 2)))
+
+;; (defun cfengine3-show-all-tokens ()
+;;   (interactive)
+;;   (goto-char (point-min))
+;;   (while (not (eobp))
+;;     (let* ((p (point))
+;;            (token (funcall smie-forward-token-function)))
+;;       (delete-region p (point))
+;;       (insert-before-markers token)
+;;       (forward-char))))
+
+;; (defun cfengine3-line-classes ()
+;;   (interactive)
+;;   (save-excursion
+;;     (beginning-of-line)
+;;     (let* ((todo (buffer-substring (point)
+;;                                    (save-excursion (end-of-line) (point))))
+;;            (original (concat (loop for c across todo
+;;                                    collect (char-syntax c)))))
+;;       (format "%s\n%s" original todo))))
+
+;; (defun cfengine3-show-all-classes ()
+;;   (interactive)
+;;   (goto-char (point-min))
+;;   (while (not (eobp))
+;;     (let ((repl (cfengine3-line-classes)))
+;;       (kill-line)
+;;       (insert repl)
+;;       (insert "\n"))))
+
+;; specification: blocks
+;; blocks: block | blocks block;
+;; block:                 bundle typeid blockid bundlebody
+;;                      | bundle typeid blockid usearglist bundlebody
+;;                      | body typeid blockid bodybody
+;;                      | body typeid blockid usearglist bodybody;
+
+;; typeid: id
+;; blockid: id
+;; usearglist: '(' aitems ')';
+;; aitems: aitem | aitem ',' aitems |;
+;; aitem: id
+
+;; bundlebody: '{' statements '}'
+;; statements: statement | statements statement;
+;; statement: category | classpromises;
+
+;; bodybody: '{' bodyattribs '}'
+;; bodyattribs: bodyattrib | bodyattribs bodyattrib;
+;; bodyattrib: class | selections;
+;; selections: selection | selections selection;
+;; selection: id ASSIGN rval ';' ;
+
+;; classpromises: classpromise | classpromises classpromise;
+;; classpromise: class | promises;
+;; promises: promise | promises promise;
+;; category: CATEGORY
+;; promise: promiser ARROW rval constraints ';' | promiser constraints ';';
+;; constraints: constraint | constraints ',' constraint |;
+;; constraint: id ASSIGN rval;
+;; class: CLASS
+;; id: ID
+;; rval: ID | QSTRING | NAKEDVAR | list | usefunction
+;; list: '{' litems '}' ;
+;; litems: litem | litem ',' litems |;
+;; litem: ID | QSTRING | NAKEDVAR | list | usefunction
+
+;; functionid: ID | NAKEDVAR
+;; promiser: QSTRING
+;; usefunction: functionid givearglist
+;; givearglist: '(' gaitems ')'
+;; gaitems: gaitem | gaitems ',' gaitem |;
+;; gaitem: ID | QSTRING | NAKEDVAR | list | usefunction
+
+;; # from lexer:
+
+;; bundle: "bundle"
+;; body: "body"
+;; COMMENT    #[^\n]*
+;; NAKEDVAR   [$@][(][a-zA-Z0-9_\200-\377.]+[)]|[$@][{][a-zA-Z0-9_\200-\377.]+[}]
+;; ID: [a-zA-Z0-9_\200-\377]+
+;; ASSIGN: "=>"
+;; ARROW: "->"
+;; QSTRING: \"((\\\")|[^"])*\"|\'((\\\')|[^'])*\'|`[^`]*`
+;; CLASS: [.|&!()a-zA-Z0-9_\200-\377]+::
+;; CATEGORY: [a-zA-Z_]+:
+
+;;;###autoload
+(define-derived-mode cfengine3-mode prog-mode "CFEngine3"
+  "Major mode for editing cfengine input.
+There are no special keybindings by default.
+
+Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
+to the action header."
+  (modify-syntax-entry ?# "<" cfengine3-mode-syntax-table)
+  (modify-syntax-entry ?\n ">#" cfengine3-mode-syntax-table)
+  (modify-syntax-entry ?\" "\"" cfengine3-mode-syntax-table)
+  ;; variable substitution:
+  (modify-syntax-entry ?$ "." cfengine3-mode-syntax-table)
+  ;; Doze path separators:
+  (modify-syntax-entry ?\\ "." cfengine3-mode-syntax-table)
+  ;; Otherwise, syntax defaults seem OK to give reasonable word
+  ;; movement.
+
+  ;; (smie-setup cfengine3-smie-grammar #'cfengine3-smie-rules)
+  ;;             ;; :forward-token  #'cfengine3-smie-forward-token
+  ;;             ;; :backward-token #'cfengine3-smie-backward-token)
+  ;; (set (make-local-variable 'smie-indent-basic) 'cfengine3-indent)
+
+  (set (make-local-variable 'parens-require-spaces) nil)
+  (set (make-local-variable 'comment-start)  "# ")
+  (set (make-local-variable 'comment-start-skip)
+       "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
+  (set (make-local-variable 'indent-line-function) #'cfengine3-indent-line)
+  (setq font-lock-defaults
+        '(cfengine3-font-lock-keywords nil nil nil beginning-of-defun))
+  ;; Fixme: set the args of functions in evaluated classes to string
+  ;; syntax, and then obey syntax properties.
+  (set (make-local-variable 'syntax-propertize-function)
+       ;; In the main syntax-table, \ is marked as a punctuation, because
+       ;; of its use in DOS-style directory separators.  Here we try to
+       ;; recognize the cases where \ is used as an escape inside strings.
+       (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\"))))
+
+  ;; use defuns as the essential syntax block
+  (set (make-local-variable 'beginning-of-defun-function)
+       #'cfengine3-beginning-of-defun)
+  (set (make-local-variable 'end-of-defun-function)
+       #'cfengine3-end-of-defun)
+
+  ;; Like Lisp mode.  Without this, we lose with, say,
+  ;; `backward-up-list' when there's an unbalanced quote in a
+  ;; preceding comment.
+  (set (make-local-variable 'parse-sexp-ignore-comments) t))
+
+(provide 'cfengine3)
+
+;;; cfengine3.el ends here
diff --git a/lisp/window.el b/lisp/window.el
index 15e603bc6c9..49698ff8bb7 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -2802,7 +2802,9 @@ displayed there."
      ((or buffer-or-name (not (eq buffer (window-buffer)))))
      ((not (window-dedicated-p))
       (switch-to-prev-buffer nil 'bury))
-     ((frame-root-window-p (selected-window))
+     ((and (frame-root-window-p (selected-window))
+           ;; Don't iconify if it's the only frame.
+           (not (eq (next-frame nil 0) (selected-frame))))
       (iconify-frame (window-frame (selected-window))))
      ((window-deletable-p)
       (delete-window)))
@@ -5944,20 +5946,18 @@ functions should call `pop-to-buffer-same-window' instead."
   (interactive
    (list (read-buffer-to-switch "Switch to buffer: ")))
   (let ((buffer (window-normalize-buffer-to-switch-to buffer-or-name)))
-    (if (and (or (window-minibuffer-p) (eq (window-dedicated-p) t))
-	     (not (eq buffer (window-buffer))))
-	;; Cannot switch to another buffer in a minibuffer or strongly
-	;; dedicated window that does not show the buffer already.  Call
-	;; `pop-to-buffer' instead.
-	(pop-to-buffer buffer 'same-window norecord)
-      (unless (eq buffer (window-buffer))
-	;; I'm not sure why we should NOT call `set-window-buffer' here,
-	;; but let's keep things as they are (otherwise we could always
-	;; call `pop-to-buffer-same-window' here).
-	(set-window-buffer nil buffer))
-      (unless norecord
-	(select-window (selected-window)))
-      (set-buffer buffer))))
+    (cond
+     ;; Don't call set-window-buffer if it's not needed since it
+     ;; might signal an error (e.g. if the window is dedicated).
+     ((eq buffer (window-buffer)) nil)
+     ((window-minibuffer-p)
+      (error "Cannot switch buffers in minibuffer window"))
+     ((eq (window-dedicated-p) t)
+      (error "Cannot switch buffers in a dedicated window"))
+     (t (set-window-buffer nil buffer)))
+    (unless norecord
+      (select-window (selected-window)))
+    (set-buffer buffer)))
 
 (defun switch-to-buffer-same-frame (buffer-or-name &optional norecord)
   "Switch to buffer BUFFER-OR-NAME in a window on the selected frame.