Initial revision

4 files changed, 3424 insertions, 0 deletions

diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
new file mode 100644
index 00000000000..57ed623485f
--- /dev/null
+++ b/lisp/mail/mail-extr.el
@@ -0,0 +1,1469 @@
+;;; mail-extr.el --- extract full name and address from RFC 822 mail header.
+
+;; Author: Joe Wells <jbw@cs.bu.edu>
+;; Last-Modified: 7 Apr 1992
+;; Version: 1.0
+;; Adapted-By: ESR
+;; Keywords: mail
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; Here is `mail-extr', a package for extracting full names and canonical
+;; addresses from RFC 822 mail headers.  It is intended to be hooked into
+;; other Emacs Lisp packages that deal with RFC 822 format messages, such as
+;; Gnews, GNUS, RMAIL, MH-E, BBDB, VM, Supercite, etc.  Thus, this release is
+;; mainly for Emacs Lisp developers.
+
+;; There are two main benefits:
+
+;; 1. Higher probability of getting the correct full name for a human than
+;;    any other package I know of.  (On the other hand, it will cheerfully
+;;    mangle non-human names/comments.)
+;; 2. Address part is put in a canonical form.
+
+;; The interface is not yet carved in stone; please give me suggestions.
+
+;; I have an extensive test-case collection of funny addresses if you want to
+;; work with the code.  Developing this code requires frequent testing to
+;; make sure you're not breaking functionality.  I'm not posting the
+;; test-cases because they take over 100K.
+
+;; If you find an address that mail-extr fails on, please send it to me along
+;; with what you think the correct results should be.  I do not consider it a
+;; bug if mail-extr mangles a comment that does not correspond to a real
+;; human full name, although I would prefer that mail-extr would return the
+;; comment as-is.
+
+;; Features:
+
+;; * Full name handling:
+
+;;   * knows where full names can be found in an address.
+;;   * avoids using empty comments and quoted text.
+;;   * extracts full names from mailbox names.
+;;   * recognizes common formats for comments after a full name.
+;;   * puts a period and a space after each initial.
+;;   * understands & referring to the mailbox name capitalized.
+;;   * strips name prefixes like "Prof.", etc..
+;;   * understands what characters can occur in names (not just letters).
+;;   * figures out middle initial from mailbox name.
+;;   * removes funny nicknames.
+;;   * keeps suffixes such as Jr., Sr., III, etc.
+;;   * reorders "Last, First" type names.
+
+;; * Address handling:
+
+;;   * parses rfc822 quoted text, comments, and domain literals.
+;;   * parses rfc822 multi-line headers.
+;;   * does something reasonable with rfc822 GROUP addresses.
+;;   * handles many rfc822 noncompliant and garbage addresses.
+;;   * canonicalizes addresses (after stripping comments/phrases outside <>).
+;;     * converts ! addresses into .UUCP and %-style addresses.
+;;     * converts rfc822 ROUTE addresses to %-style addresses.
+;;     * truncates %-style addresses at leftmost fully qualified domain name.
+;;     * handles local relative precedence of ! vs. % and @ (untested).
+
+;; It does almost no string creation.  It primarily uses the built-in
+;; parsing routines with the appropriate syntax tables.  This should
+;; result in greater speed.
+
+;; TODO:
+
+;; * handle all test cases.  (This will take forever.)
+;; * software to pick the correct header to use (eg., "Senders-Name:").
+;; * multiple addresses in the "From:" header (almost all of the necessary
+;;   code is there).
+;; * flag to not treat `,' as an address separator.  (This is useful when
+;;   there is a "From:" header but no "Sender:" header, because then there
+;;   is only allowed to be one address.)
+;; * mailbox name does not necessarily contain full name.
+;; * fixing capitalization when it's all upper or lowercase.  (Hard!)
+;; * some of the domain literal handling is missing.  (But I've never even
+;;   seen one of these in a mail address, so maybe no big deal.)
+;; * arrange to have syntax tables byte-compiled.
+;; * speed hacks.
+;; * delete unused variables.
+;; * arrange for testing with different relative precedences of ! vs. @
+;;   and %.
+;; * put variant-method back into mail-extract-address-components.
+;; * insert documentation strings!
+;; * handle X.400-gatewayed addresses according to RFC 1148.
+
+;;; Change Log: 
+;; 
+;; Mon Apr  6 23:59:09 1992  Joe Wells  (jbw at bigbird.bu.edu)
+;; 
+;;      * Cleaned up some more.  Release version 1.0 to world.
+;; 
+;; Sun Apr  5 19:39:08 1992  Joe Wells  (jbw at bigbird.bu.edu)
+;; 
+;;      * Cleaned up full name extraction extensively.
+;; 
+;; Sun Feb  2 14:45:24 1992  Joe Wells  (jbw at bigbird.bu.edu)
+;; 
+;;      * Total rewrite.  Integrated mail-canonicalize-address into
+;;      mail-extract-address-components.  Now handles GROUP addresses more
+;;      or less correctly.  Better handling of lots of different cases.
+;; 
+;; Fri Jun 14 19:39:50 1991
+;;      * Created.
+
+;;; Code:
+
+;; Variable definitions.
+
+(defvar mail-@-binds-tighter-than-! nil)
+
+;;----------------------------------------------------------------------
+;; what orderings are meaningful?????
+;;(defvar mail-operator-precedence-list '(?! ?% ?@))
+;; Right operand of a % or a @ must be a domain name, period.  No other
+;; operators allowed.  Left operand of a @ is an address relative to that
+;; site.
+
+;; Left operand of a ! must be a domain name.  Right operand is an
+;; arbitrary address.
+;;----------------------------------------------------------------------
+
+(defconst mail-space-char 32)
+
+(defconst mail-whitespace " \t\n")
+
+;; Any character that can occur in a name in an RFC822 address.
+;; Yes, there are weird people with digits in their names.
+(defconst mail-all-letters "A-Za-z---{|}'~0-9`.")
+
+;; Any character that can occur in a name, not counting characters that
+;; separate parts of a multipart name.
+(defconst mail-all-letters-but-separators "A-Za-z{|}'~0-9`")
+
+;; Any character that can start a name
+(defconst mail-first-letters "A-Za-z")
+
+;; Any character that can end a name.
+(defconst mail-last-letters "A-Za-z`'.")
+
+;; Matches an initial not followed by both a period and a space. 
+(defconst mail-bad-initials-pattern
+  (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
+          mail-all-letters mail-first-letters mail-all-letters))
+
+(defconst mail-non-name-chars (concat "^" mail-all-letters "."))
+
+(defconst mail-non-begin-name-chars (concat "^" mail-first-letters))
+
+(defconst mail-non-end-name-chars (concat "^" mail-last-letters))
+
+;; Matches periods used instead of spaces.  Must not match the period
+;; following an initial.
+(defconst mail-bad-\.-pattern
+  (format "\\([%s][%s]\\)\\.+\\([%s]\\)"
+          mail-all-letters mail-last-letters mail-first-letters))
+
+;; Matches an embedded or leading nickname that should be removed.
+(defconst mail-nickname-pattern
+  (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] "
+          mail-all-letters))
+
+;; Matches a leading title that is not part of the name (does not
+;; contribute to uniquely identifying the person).
+(defconst mail-full-name-prefixes
+      '"\\` *\\(Prof\\|Dr\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.? ")
+
+;; Matches the occurrence of a generational name suffix, and the last
+;; character of the preceding name.
+(defconst mail-full-name-suffix-pattern
+  (format
+   "\\(,? ?\\([JjSs]r\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)"
+   mail-all-letters mail-all-letters))
+
+(defconst mail-roman-numeral-pattern
+  "V?I+V?\\b")
+
+;; Matches a trailing uppercase (with other characters possible) acronym.
+;; Must not match a trailing uppercase last name or trailing initial
+(defconst mail-weird-acronym-pattern "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)")
+      
+;; Matches a mixed-case or lowercase name (not an initial).
+(defconst mail-mixed-case-name-pattern
+  (format
+   "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)"
+   mail-all-letters mail-last-letters
+   mail-first-letters mail-all-letters mail-all-letters mail-last-letters
+   mail-first-letters mail-all-letters))
+
+;; Matches a trailing alternative address.
+(defconst mail-alternative-address-pattern "[a-zA-Z.]+[!@][a-zA-Z.]")
+
+;; Matches a variety of trailing comments not including comma-delimited
+;; comments.
+(defconst mail-trailing-comment-start-pattern " [-{]\\|--\\|[+@#></\;]")
+
+;; Matches a name (not an initial).
+;; This doesn't force a word boundary at the end because sometimes a
+;; comment is separated by a `-' with no preceding space.
+(defconst mail-name-pattern
+  (format
+   "\\b[%s][%s]*[%s]"
+   mail-first-letters mail-all-letters mail-last-letters))
+
+(defconst mail-initial-pattern
+  (format "\\b[%s]\\([. ]\\|\\b\\)" mail-first-letters))
+
+;; Matches a single name before a comma.
+(defconst mail-last-name-first-pattern
+  (concat "\\`" mail-name-pattern ","))
+
+;; Matches telephone extensions.
+(defconst mail-telephone-extension-pattern
+  "\\(\\([Ee]xt\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+")
+
+;; Matches ham radio call signs.
+(defconst mail-ham-call-sign-pattern
+  "\\b[A-Z]+[0-9][A-Z0-9]*")
+
+;; Matches normal single-part name
+(defconst mail-normal-name-pattern
+  (format
+   "\\b[%s][%s]+[%s]"
+   mail-first-letters mail-all-letters-but-separators mail-last-letters))
+
+;; Matches normal two names with missing middle initial
+(defconst mail-two-name-pattern
+  (concat "\\`\\(" mail-normal-name-pattern
+          "\\|" mail-initial-pattern
+          "\\) +\\(" mail-normal-name-pattern "\\)\\(,\\|\\'\\)"))
+
+(defvar address-syntax-table (make-syntax-table))
+(defvar address-comment-syntax-table (make-syntax-table))
+(defvar address-domain-literal-syntax-table (make-syntax-table))
+(defvar address-text-comment-syntax-table (make-syntax-table))
+(defvar address-text-syntax-table (make-syntax-table))
+(mapcar
+ (function
+  (lambda (pair)
+    (let ((syntax-table (symbol-value (car pair))))
+      (mapcar
+       (function
+        (lambda (item)
+          (if (eq 2 (length item))
+              (modify-syntax-entry (car item) (car (cdr item)) syntax-table)
+            (let ((char (car item))
+                  (bound (car (cdr item)))
+                  (syntax (car (cdr (cdr item)))))
+              (while (<= char bound)
+                (modify-syntax-entry char syntax syntax-table)
+                (setq char (1+ char)))))))
+       (cdr pair)))))
+ '((address-syntax-table
+    (0  31   "w")                       ;control characters
+    (32      " ")                       ;SPC
+    (?! ?~   "w")                       ;printable characters
+    (127     "w")                       ;DEL
+    (128 255 "w")                       ;high-bit-on characters
+    (?\t " ")
+    (?\r " ")
+    (?\n " ")
+    (?\( ".")
+    (?\) ".")
+    (?<  ".")
+    (?>  ".")
+    (?@  ".")
+    (?,  ".")
+    (?\; ".")
+    (?:  ".")
+    (?\\ "\\")
+    (?\" "\"")
+    (?.  ".")
+    (?\[ ".")
+    (?\] ".")
+    ;; % and ! aren't RFC822 characters, but it is convenient to pretend
+    (?%  ".")
+    (?!  ".")
+    )
+   (address-comment-syntax-table
+    (0 255 "w")
+    (?\( "\(\)")
+    (?\) "\)\(")
+    (?\\ "\\"))
+   (address-domain-literal-syntax-table
+    (0 255 "w")
+    (?\[ "\(\]")                        ;??????
+    (?\] "\)\[")                        ;??????
+    (?\\ "\\"))
+   (address-text-comment-syntax-table
+    (0 255 "w")
+    (?\( "\(\)")
+    (?\) "\)\(")
+    (?\[ "\(\]")
+    (?\] "\)\[")
+    (?\{ "\(\}")
+    (?\} "\)\{")
+    (?\\ "\\")
+    (?\" "\"")
+    ;; (?\' "\)\`")
+    ;; (?\` "\(\'")
+    )
+   (address-text-syntax-table
+    (0 255 ".")
+    (?A ?Z "w")
+    (?a ?z "w")
+    (?-    "w")
+    (?\}   "w")
+    (?\{   "w")
+    (?|    "w")
+    (?\'   "w")
+    (?~    "w")
+    (?0 ?9 "w"))
+   ))
+
+
+;; Utility functions and macros.
+
+(defmacro undo-backslash-quoting (beg end)
+  (`(save-excursion
+      (save-restriction
+        (narrow-to-region (, beg) (, end))
+        (goto-char (point-min))
+        ;; undo \ quoting
+        (while (re-search-forward "\\\\\\(.\\)" nil t)
+          (replace-match "\\1")
+          ;; CHECK: does this leave point after the replacement?
+          )))))
+
+(defmacro mail-nuke-char-at (pos)
+  (` (save-excursion
+       (goto-char (, pos))
+       (delete-char 1)
+       (insert mail-space-char))))
+
+(defmacro mail-nuke-elements-outside-range (list-symbol beg-symbol end-symbol
+                                                        &optional no-replace)
+  (` (progn
+       (setq temp (, list-symbol))
+       (while temp
+         (cond ((or (> (car temp) (, end-symbol))
+                    (< (car temp) (, beg-symbol)))
+                (, (or no-replace
+                       (` (mail-nuke-char-at (car temp)))))
+                (setcar temp nil)))
+         (setq temp (cdr temp)))
+       (setq (, list-symbol) (delq nil (, list-symbol))))))
+
+(defun mail-demarkerize (marker)
+  (and marker
+       (if (markerp marker)
+           (let ((temp (marker-position marker)))
+             (set-marker marker nil)
+             temp)
+         marker)))
+
+(defun mail-markerize (pos)
+  (and pos
+       (if (markerp pos)
+           pos
+         (copy-marker pos))))
+
+(defmacro mail-last-element (list)
+  "Return last element of LIST."
+  (` (let ((list (, list)))
+       (while (not (null (cdr list)))
+         (setq list (cdr list)))
+       (car list))))
+  
+(defmacro safe-move-sexp (arg)
+  "Safely skip over one balanced sexp, if there is one.  Return t if success."
+  (` (condition-case error
+         (progn
+           (goto-char (scan-sexps (point) (, arg)))
+           t)
+       (error
+        (if (string-equal (nth 1 error) "Unbalanced parentheses")
+            nil
+          (while t
+            (signal (car error) (cdr error))))))))
+
+
+;; The main function to grind addresses
+
+(defun mail-extract-address-components (address)
+  "Given an rfc 822 ADDRESS, extract full name and canonical address.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS)."
+  (let ((canonicalization-buffer (get-buffer-create "*canonical address*"))
+        (extraction-buffer (get-buffer-create "*extract address components*"))
+        (foo 'bar)
+        char
+        multiple-addresses
+        <-pos >-pos @-pos :-pos ,-pos !-pos %-pos \;-pos
+        group-:-pos group-\;-pos route-addr-:-pos
+        record-pos-symbol
+        first-real-pos last-real-pos
+        phrase-beg phrase-end
+        comment-beg comment-end
+        quote-beg quote-end
+        atom-beg atom-end
+        mbox-beg mbox-end
+        \.-ends-name
+        temp
+        name-suffix
+        saved-point
+        fi mi li
+        saved-%-pos saved-!-pos saved-@-pos
+        domain-pos \.-pos insert-point)
+    
+    (save-excursion
+      (set-buffer extraction-buffer)
+      (buffer-flush-undo extraction-buffer)
+      (set-syntax-table address-syntax-table)
+      (widen)
+      (erase-buffer)
+      (setq case-fold-search nil)
+      
+      ;; Insert extra space at beginning to allow later replacement with <
+      ;; without having to move markers.
+      (insert mail-space-char address)
+      
+      ;; stolen from rfc822.el
+      ;; Unfold multiple lines.
+      (goto-char (point-min))
+      (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
+        (replace-match "\\1 " t))
+      
+      ;; first pass grabs useful information about address
+      (goto-char (point-min))
+      (while (progn
+               (skip-chars-forward mail-whitespace)
+               (not (eobp)))
+        (setq char (char-after (point)))
+        (or first-real-pos
+            (if (not (eq char ?\())
+                (setq first-real-pos (point))))
+        (cond
+         ;; comment
+         ((eq char ?\()
+          (set-syntax-table address-comment-syntax-table)
+          ;; only record the first non-empty comment's position
+          (if (and (not comment-beg)
+                   (save-excursion
+                     (forward-char 1)
+                     (skip-chars-forward mail-whitespace)
+                     (not (eq ?\) (char-after (point))))))
+              (setq comment-beg (point)))
+          ;; TODO: don't record if unbalanced
+          (or (safe-move-sexp 1)
+              (forward-char 1))
+          (set-syntax-table address-syntax-table)
+          (if (and comment-beg
+                   (not comment-end))
+              (setq comment-end (point))))
+         ;; quoted text
+         ((eq char ?\")
+          ;; only record the first non-empty quote's position
+          (if (and (not quote-beg)
+                   (save-excursion
+                     (forward-char 1)
+                     (skip-chars-forward mail-whitespace)
+                     (not (eq ?\" (char-after (point))))))
+              (setq quote-beg (point)))
+          ;; TODO: don't record if unbalanced
+          (or (safe-move-sexp 1)
+              (forward-char 1))
+          (if (and quote-beg
+                   (not quote-end))
+              (setq quote-end (point))))
+         ;; domain literals
+         ((eq char ?\[)
+          (set-syntax-table address-domain-literal-syntax-table)
+          (or (safe-move-sexp 1)
+              (forward-char 1))
+          (set-syntax-table address-syntax-table))
+         ;; commas delimit addresses when outside < > pairs.
+         ((and (eq char ?,)
+               (or (null <-pos)
+                   (and >-pos
+                        ;; handle weird munged addresses
+                        (> (mail-last-element <-pos) (car >-pos)))))
+          (setq multiple-addresses t)
+          (delete-char 1)
+          (narrow-to-region (point-min) (point)))
+         ;; record the position of various interesting chars, determine
+         ;; legality later.
+         ((setq record-pos-symbol
+                (cdr (assq char
+                           '((?< . <-pos) (?> . >-pos) (?@ . @-pos)
+                             (?: . :-pos) (?, . ,-pos) (?! . !-pos)
+                             (?% . %-pos) (?\; . \;-pos)))))
+          (set record-pos-symbol
+               (cons (point) (symbol-value record-pos-symbol)))
+          (forward-char 1))
+         ((eq char ?.)
+          (forward-char 1))
+         ((memq char '(
+                       ;; comment terminator illegal
+                       ?\)
+                       ;; domain literal terminator illegal
+                       ?\]
+                       ;; \ allowed only within quoted strings,
+                       ;; domain literals, and comments
+                       ?\\
+                       ))
+          (mail-nuke-char-at (point))
+          (forward-char 1))
+         (t
+          (forward-word 1)))
+        (or (eq char ?\()
+            (setq last-real-pos (point))))
+      
+      ;; Use only the leftmost <, if any.  Replace all others with spaces.
+      (while (cdr <-pos)
+        (mail-nuke-char-at (car <-pos))
+        (setq <-pos (cdr <-pos)))
+      
+      ;; Use only the rightmost >, if any.  Replace all others with spaces.
+      (while (cdr >-pos)
+        (mail-nuke-char-at (nth 1 >-pos))
+        (setcdr >-pos (nthcdr 2 >-pos)))
+      
+      ;; If multiple @s and a :, but no < and >, insert around buffer.
+      ;; This commonly happens on the UUCP "From " line.  Ugh.
+      (cond ((and (> (length @-pos) 1)
+                  :-pos                 ;TODO: check if between @s
+                  (not <-pos))
+             (goto-char (point-min))
+             (delete-char 1)
+             (setq <-pos (list (point)))
+             (insert ?<)))
+      
+      ;; If < but no >, insert > in rightmost possible position
+      (cond ((and <-pos
+                  (null >-pos))
+             (goto-char (point-max))
+             (setq >-pos (list (point)))
+             (insert ?>)))
+      
+      ;; If > but no <, replace > with space.
+      (cond ((and >-pos
+                  (null <-pos))
+             (mail-nuke-char-at (car >-pos))
+             (setq >-pos nil)))
+
+      ;; Turn >-pos and <-pos into non-lists
+      (setq >-pos (car >-pos)
+            <-pos (car <-pos))
+      
+      ;; Trim other punctuation lists of items outside < > pair to handle
+      ;; stupid MTAs.
+      (cond (<-pos                      ; don't need to check >-pos also
+             ;; handle bozo software that violates RFC 822 by sticking
+             ;; punctuation marks outside of a < > pair
+             (mail-nuke-elements-outside-range @-pos <-pos >-pos t)
+             ;; RFC 822 says nothing about these two outside < >, but
+             ;; remove those positions from the lists to make things
+             ;; easier.
+             (mail-nuke-elements-outside-range !-pos <-pos >-pos t)
+             (mail-nuke-elements-outside-range %-pos <-pos >-pos t)))
+      
+      ;; Check for : that indicates GROUP list and for : part of
+      ;; ROUTE-ADDR spec.
+      ;; Can't possibly be more than two :.  Nuke any extra.
+      (while :-pos
+        (setq temp (car :-pos)
+              :-pos (cdr :-pos))
+        (cond ((and <-pos >-pos
+                    (> temp <-pos)
+                    (< temp >-pos))
+               (if (or route-addr-:-pos
+                       (< (length @-pos) 2)
+                       (> temp (car @-pos))
+                       (< temp (nth 1 @-pos)))
+                   (mail-nuke-char-at temp)
+                 (setq route-addr-:-pos temp)))
+              ((or (not <-pos)
+                   (and <-pos
+                        (< temp <-pos)))
+               (setq group-:-pos temp))))
+      
+      ;; Nuke any ; that is in or to the left of a < > pair or to the left
+      ;; of a GROUP starting :.  Also, there may only be one ;.
+      (while \;-pos
+        (setq temp (car \;-pos)
+              \;-pos (cdr \;-pos))
+        (cond ((and <-pos >-pos
+                    (> temp <-pos)
+                    (< temp >-pos))
+               (mail-nuke-char-at temp))
+              ((and (or (not group-:-pos)
+                        (> temp group-:-pos))
+                    (not group-\;-pos))
+               (setq group-\;-pos temp))))
+      
+      ;; Handle junk like ";@host.company.dom" that sendmail adds.
+      ;; **** should I remember comment positions?
+      (and group-\;-pos
+           ;; this is fine for now
+           (mail-nuke-elements-outside-range !-pos group-:-pos group-\;-pos t)
+           (mail-nuke-elements-outside-range @-pos group-:-pos group-\;-pos t)
+           (mail-nuke-elements-outside-range %-pos group-:-pos group-\;-pos t)
+           (mail-nuke-elements-outside-range ,-pos group-:-pos group-\;-pos t)
+           (and last-real-pos
+                (> last-real-pos (1+ group-\;-pos))
+                (setq last-real-pos (1+ group-\;-pos)))
+           (and comment-end
+                (> comment-end group-\;-pos)
+                (setq comment-end nil
+                      comment-beg nil))
+           (and quote-end
+                (> quote-end group-\;-pos)
+                (setq quote-end nil
+                      quote-beg nil))
+           (narrow-to-region (point-min) group-\;-pos))
+      
+      ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
+      ;; others.
+      ;; Hell, go ahead an nuke all of the commas.
+      ;; **** This will cause problems when we start handling commas in
+      ;; the PHRASE part .... no it won't ... yes it will ... ?????
+      (mail-nuke-elements-outside-range ,-pos 1 1)
+      
+      ;; can only have multiple @s inside < >.  The fact that some MTAs
+      ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is
+      ;; handled above.
+      
+      ;; Locate PHRASE part of ROUTE-ADDR.
+      (cond (<-pos
+             (goto-char <-pos)
+             (skip-chars-backward mail-whitespace)
+             (setq phrase-end (point))
+             (goto-char (or ;;group-:-pos
+                            (point-min)))
+             (skip-chars-forward mail-whitespace)
+             (if (< (point) phrase-end)
+                 (setq phrase-beg (point))
+               (setq phrase-end nil))))
+      
+      ;; handle ROUTE-ADDRS with real ROUTEs.
+      ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and
+      ;; any % or ! must be semantically meaningless.
+      ;; TODO: do this processing into canonicalization buffer
+      (cond (route-addr-:-pos
+             (setq !-pos nil
+                   %-pos nil
+                   >-pos (copy-marker >-pos)
+                   route-addr-:-pos (copy-marker route-addr-:-pos))
+             (goto-char >-pos)
+             (insert-before-markers ?X)
+             (goto-char (car @-pos))
+             (while (setq @-pos (cdr @-pos))
+               (delete-char 1)
+               (setq %-pos (cons (point-marker) %-pos))
+               (insert "%")
+               (goto-char (1- >-pos))
+               (save-excursion
+                 (insert-buffer-substring extraction-buffer
+                                          (car @-pos) route-addr-:-pos)
+                 (delete-region (car @-pos) route-addr-:-pos))
+               (or (cdr @-pos)
+                   (setq saved-@-pos (list (point)))))
+             (setq @-pos saved-@-pos)
+             (goto-char >-pos)
+             (delete-char -1)
+             (mail-nuke-char-at route-addr-:-pos)
+             (mail-demarkerize route-addr-:-pos)
+             (setq route-addr-:-pos nil
+                   >-pos (mail-demarkerize >-pos)
+                   %-pos (mapcar 'mail-demarkerize %-pos))))
+      
+      ;; de-listify @-pos
+      (setq @-pos (car @-pos))
+      
+      ;; TODO: remove comments in the middle of an address
+      
+      (set-buffer canonicalization-buffer)
+      
+      (buffer-flush-undo canonicalization-buffer)
+      (set-syntax-table address-syntax-table)
+      (setq case-fold-search nil)
+      
+      (widen)
+      (erase-buffer)
+      (insert-buffer-substring extraction-buffer)
+      
+      (if <-pos
+          (narrow-to-region (progn
+                              (goto-char (1+ <-pos))
+                              (skip-chars-forward mail-whitespace)
+                              (point))
+                            >-pos)
+        ;; ****** Oh no!  What if the address is completely empty!
+        (narrow-to-region first-real-pos last-real-pos))
+      
+      (and @-pos %-pos
+           (mail-nuke-elements-outside-range %-pos (point-min) @-pos))
+      (and %-pos !-pos
+           (mail-nuke-elements-outside-range !-pos (point-min) (car %-pos)))
+      (and @-pos !-pos (not %-pos)
+           (mail-nuke-elements-outside-range !-pos (point-min) @-pos))
+      
+      ;; Error condition:?? (and %-pos (not @-pos))
+
+      (cond (!-pos
+             ;; **** I don't understand this save-restriction and the
+             ;; narrow-to-region inside it.  Why did I do that?
+             (save-restriction
+               (cond ((and @-pos
+                           mail-@-binds-tighter-than-!)
+                      (goto-char @-pos)
+                      (setq %-pos (cons (point) %-pos)
+                            @-pos nil)
+                      (delete-char 1)
+                      (insert "%")
+                      (setq insert-point (point-max)))
+                     (mail-@-binds-tighter-than-!
+                      (setq insert-point (point-max)))
+                     (%-pos
+                      (setq insert-point (mail-last-element %-pos)
+                            saved-%-pos (mapcar 'mail-markerize %-pos)
+                            %-pos nil
+                            @-pos (mail-markerize @-pos)))
+                     (@-pos
+                      (setq insert-point @-pos)
+                      (setq @-pos (mail-markerize @-pos)))
+                     (t
+                      (setq insert-point (point-max))))
+               (narrow-to-region (point-min) insert-point)
+               (setq saved-!-pos (car !-pos))
+               (while !-pos
+                 (goto-char (point-max))
+                 (cond ((and (not @-pos)
+                             (not (cdr !-pos)))
+                        (setq @-pos (point))
+                        (insert-before-markers "@ "))
+                       (t
+                        (setq %-pos (cons (point) %-pos))
+                        (insert-before-markers "% ")))
+                 (backward-char 1)
+                 (insert-buffer-substring 
+                  (current-buffer)
+                  (if (nth 1 !-pos)
+                      (1+ (nth 1 !-pos))
+                    (point-min))
+                  (car !-pos))
+                 (delete-char 1)
+                 (or (save-excursion
+                       (safe-move-sexp -1)
+                       (skip-chars-backward mail-whitespace)
+                       (eq ?. (preceding-char)))
+                     (insert-before-markers
+                      (if (save-excursion
+                            (skip-chars-backward mail-whitespace)
+                            (eq ?. (preceding-char)))
+                          ""
+                        ".")
+                      "uucp"))
+                 (setq !-pos (cdr !-pos))))
+             (and saved-%-pos
+                  (setq %-pos (append (mapcar 'mail-demarkerize saved-%-pos)
+                                        %-pos)))
+             (setq @-pos (mail-demarkerize @-pos))
+             (narrow-to-region (1+ saved-!-pos) (point-max))))
+      (cond ((and %-pos
+                  (not @-pos))
+             (goto-char (car %-pos))
+             (delete-char 1)
+             (setq @-pos (point))
+             (insert "@")
+             (setq %-pos (cdr %-pos))))
+      (setq %-pos (nreverse %-pos))
+      ;; RFC 1034 doesn't approve of this, oh well:
+      (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
+      (cond (%-pos                      ; implies @-pos valid
+             (setq temp %-pos)
+             (catch 'truncated
+               (while temp
+                 (goto-char (or (nth 1 temp)
+                                @-pos))
+                 (skip-chars-backward mail-whitespace)
+                 (save-excursion
+                   (safe-move-sexp -1)
+                   (setq domain-pos (point))
+                   (skip-chars-backward mail-whitespace)
+                   (setq \.-pos (eq ?. (preceding-char))))
+                 (cond ((and \.-pos
+                             (get
+                              (intern
+                               (buffer-substring domain-pos (point)))
+                              'domain-name))
+                        (narrow-to-region (point-min) (point))
+                        (goto-char (car temp))
+                        (delete-char 1)
+                        (setq @-pos (point))
+                        (setcdr temp nil)
+                        (setq %-pos (delq @-pos %-pos))
+                        (insert "@")
+                        (throw 'truncated t)))
+                 (setq temp (cdr temp))))))
+      (setq mbox-beg (point-min)
+            mbox-end (if %-pos (car %-pos)
+                       (or @-pos
+                           (point-max))))
+      
+      ;; Done canonicalizing address.
+      
+      (set-buffer extraction-buffer)
+      
+      ;; Find the full name
+      
+      (cond ((and phrase-beg
+                  (eq quote-beg phrase-beg)
+                  (<= quote-end phrase-end))
+             (narrow-to-region (1+ quote-beg) (1- quote-end))
+             (undo-backslash-quoting (point-min) (point-max)))
+            (phrase-beg
+             (narrow-to-region phrase-beg phrase-end))
+            (comment-beg
+             (narrow-to-region (1+ comment-beg) (1- comment-end))
+             (undo-backslash-quoting (point-min) (point-max)))
+            (t
+             ;; *** Work in canon buffer instead?  No, can't.  Hmm.
+             (delete-region (point-min) (point-max))
+             (insert-buffer-substring canonicalization-buffer
+                                      mbox-beg mbox-end)
+             (goto-char (point-min))
+             (setq \.-ends-name (search-forward "_" nil t))
+             (goto-char (point-min))
+             (while (progn
+                      (skip-chars-forward mail-whitespace)
+                      (not (eobp)))
+               (setq char (char-after (point)))
+               (cond
+                ((eq char ?\")
+                 (setq quote-beg (point))
+                 (or (safe-move-sexp 1)
+                     ;; TODO: handle this error condition!!!!!
+                     (forward-char 1))
+                 ;; take into account deletions
+                 (setq quote-end (- (point) 2))
+                 (save-excursion
+                   (backward-char 1)
+                   (delete-char 1)
+                   (goto-char quote-beg)
+                   (delete-char 1))
+                 (undo-backslash-quoting quote-beg quote-end)
+                 (or (eq mail-space-char (char-after (point)))
+                     (insert " "))
+                 (setq \.-ends-name t))
+                ((eq char ?.)
+                 (if (eq (char-after (1+ (point))) ?_)
+                     (progn
+                       (forward-char 1)
+                       (delete-char 1)
+                       (insert mail-space-char))
+                   (if \.-ends-name
+                       (narrow-to-region (point-min) (point))
+                     (delete-char 1)
+                     (insert " "))))
+                ((memq (char-syntax char) '(?. ?\\))
+                 (delete-char 1)
+                 (insert " "))
+                (t
+                 (setq atom-beg (point))
+                 (forward-word 1)
+                 (setq atom-end (point))
+                 (save-restriction
+                   (narrow-to-region atom-beg atom-end)
+                   (goto-char (point-min))
+                   (while (re-search-forward "\\([^_]+\\)_" nil t)
+                     (replace-match "\\1 "))
+                   (goto-char (point-max))))))))
+      
+      (set-syntax-table address-text-syntax-table)
+      
+      (setq xxx (variant-method (buffer-string)))
+      (delete-region (point-min) (point-max))
+      (insert xxx)
+      (goto-char (point-min))
+
+;;       ;; Compress whitespace
+;;       (goto-char (point-min))
+;;       (while (re-search-forward "[ \t\n]+" nil t)
+;;      (replace-match " "))
+;;       
+;;       ;; Fix . used as space
+;;       (goto-char (point-min))
+;;       (while (re-search-forward mail-bad-\.-pattern nil t)
+;;      (replace-match "\\1 \\2"))
+;; 
+;;       ;; Delete trailing parenthesized comment
+;;       (goto-char (point-max))
+;;       (skip-chars-backward mail-whitespace)
+;;       (cond ((memq (char-after (1- (point))) '(?\) ?\} ?\]))
+;;           (setq comment-end (point))
+;;           (set-syntax-table address-text-comment-syntax-table)
+;;           (or (safe-move-sexp -1)
+;;               (backward-char 1))
+;;           (set-syntax-table address-text-syntax-table)
+;;           (setq comment-beg (point))
+;;           (skip-chars-backward mail-whitespace)
+;;           (if (bobp)
+;;               (narrow-to-region (1+ comment-beg) (1- comment-end))
+;;             (narrow-to-region (point-min) (point)))))
+;;       
+;;       ;; Find, save, and delete any name suffix
+;;       ;; *** Broken!
+;;       (goto-char (point-min))
+;;       (cond ((re-search-forward mail-full-name-suffix-pattern nil t)
+;;           (setq name-suffix (buffer-substring (match-beginning 3)
+;;                                               (match-end 3)))
+;;           (replace-match "\\1 \\4")))
+;;       
+;;       ;; Delete ALL CAPS words and after, if preceded by mixed-case or
+;;       ;; lowercase words.  Eg. XT-DEM.
+;;       (goto-char (point-min))
+;;       ;; ## This will lose on something like "SMITH MAX".
+;;       ;; ## maybe it should be
+;;       ;; ##  " \\([A-Z]+[-_/][A-Z]+\\|[A-Z][A-Z][A-Z]\\)\\b.*[^A-Z \t]"
+;;       ;; ## that is, three-letter-upper-case-word with non-upper-case
+;;       ;; ## characters following it.
+;;       (if (re-search-forward mail-mixed-case-name-pattern nil t)
+;;        (if (re-search-forward mail-weird-acronym-pattern nil t)
+;;            (narrow-to-region (point-min) (match-beginning 0))))
+;;       
+;;       ;; Delete trailing alternative address
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-alternative-address-pattern nil t)
+;;        (narrow-to-region (point-min) (match-beginning 0)))
+;;       
+;;       ;; Delete trailing comment
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-trailing-comment-start-pattern nil t)
+;;        (or (progn
+;;              (goto-char (match-beginning 0))
+;;              (skip-chars-backward mail-whitespace)
+;;              (bobp))
+;;            (narrow-to-region (point-min) (match-beginning 0))))
+;;       
+;;       ;; Delete trailing comma-separated comment
+;;       (goto-char (point-min))
+;;       ;; ## doesn't this break "Smith, John"?  Yes.
+;;       (re-search-forward mail-last-name-first-pattern nil t)
+;;       (while (search-forward "," nil t)
+;;      (or (save-excursion
+;;            (backward-char 2)
+;;            (looking-at mail-full-name-suffix-pattern))
+;;          (narrow-to-region (point-min) (1- (point)))))
+;;       
+;;       ;; Delete telephone numbers and ham radio call signs
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-telephone-extension-pattern nil t)
+;;        (narrow-to-region (point-min) (match-beginning 0)))
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-ham-call-sign-pattern nil t)
+;;        (if (eq (match-beginning 0) (point-min))
+;;            (narrow-to-region (match-end 0) (point-max))
+;;          (narrow-to-region (point-min) (match-beginning 0))))
+;;       
+;;       ;; Delete trailing word followed immediately by .
+;;       (goto-char (point-min))
+;;       ;; ## what's this for?  doesn't it mess up "Public, Harry Q."?  No.
+;;       (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t)
+;;        (narrow-to-region (point-min) (match-beginning 0)))
+;;       
+;;       ;; Handle & substitution
+;;       ;; TODO: remember to disable middle initial guessing
+;;       (goto-char (point-min))
+;;       (cond ((re-search-forward "\\( \\|\\`\\)&\\( \\|\\'\\)" nil t)
+;;           (goto-char (match-end 1))
+;;           (delete-char 1)
+;;           (capitalize-region
+;;            (point)
+;;            (progn
+;;              (insert-buffer-substring canonicalization-buffer
+;;                                       mbox-beg mbox-end)
+;;              (point)))))
+;;       
+;;       ;; Delete nickname
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-nickname-pattern nil t)
+;;        (replace-match (if (eq (match-beginning 2) (1- (match-end 2)))
+;;                           " \\2 "
+;;                         " ")))
+;;       
+;;       ;; Fixup initials
+;;       (while (progn
+;;             (goto-char (point-min))
+;;             (re-search-forward mail-bad-initials-pattern nil t))
+;;      (replace-match
+;;       (if (match-beginning 4)
+;;           "\\1. \\4"
+;;         (if (match-beginning 5)
+;;             "\\1. \\5"
+;;           "\\1. "))))
+;;       
+;;       ;; Delete title
+;;       (goto-char (point-min))
+;;       (if (re-search-forward mail-full-name-prefixes nil t)
+;;        (narrow-to-region (point) (point-max)))
+;;       
+;;       ;; Delete trailing and preceding non-name characters
+;;       (goto-char (point-min))
+;;       (skip-chars-forward mail-non-begin-name-chars)
+;;       (narrow-to-region (point) (point-max))
+;;       (goto-char (point-max))
+;;       (skip-chars-backward mail-non-end-name-chars)
+;;       (narrow-to-region (point-min) (point))
+      
+      ;; If name is "First Last" and userid is "F?L", then assume
+      ;; the middle initial is the second letter in the userid.
+      ;; initially by Jamie Zawinski <jwz@lucid.com>
+      (cond ((and (eq 3 (- mbox-end mbox-beg))
+                  (progn
+                    (goto-char (point-min))
+                    (looking-at mail-two-name-pattern)))
+             (setq fi (char-after (match-beginning 0))
+                   li (char-after (match-beginning 3)))
+             (save-excursion
+               (set-buffer canonicalization-buffer)
+               ;; char-equal is ignoring case here, so no need to upcase
+               ;; or downcase.
+               (let ((case-fold-search t))
+                 (and (char-equal fi (char-after mbox-beg))
+                      (char-equal li (char-after (1- mbox-end)))
+                      (setq mi (char-after (1+ mbox-beg))))))
+             (cond ((and mi
+                         ;; TODO: use better table than syntax table
+                         (eq ?w (char-syntax mi)))
+                    (goto-char (match-beginning 3))
+                    (insert (upcase mi) ". ")))))
+      
+;;       ;; Restore suffix
+;;       (cond (name-suffix
+;;           (goto-char (point-max))
+;;           (insert ", " name-suffix)
+;;           (backward-word 1)
+;;           (cond ((memq (following-char) '(?j ?J ?s ?S))
+;;                  (capitalize-word 1)
+;;                  (or (eq (following-char) ?.)
+;;                      (insert ?.)))
+;;                 (t
+;;                  (upcase-word 1)))))
+      
+      ;; Result
+      (list (buffer-string)
+            (progn
+              (set-buffer canonicalization-buffer)
+              (buffer-string)))
+      )))
+
+;; TODO: put this back in the above function now that it's proven:
+(defun variant-method (string)
+  (let ((variant-buffer (get-buffer-create "*variant method buffer*"))
+        (word-count 0)
+        mixed-case-flag lower-case-flag upper-case-flag
+        suffix-flag last-name-comma-flag
+        comment-beg comment-end initial beg end
+        )
+    (save-excursion
+      (set-buffer variant-buffer)
+      (buffer-flush-undo variant-buffer)
+      (set-syntax-table address-text-syntax-table)
+      (widen)
+      (erase-buffer)
+      (setq case-fold-search nil)
+      
+      (insert string)
+      
+      ;; Fix . used as space
+      (goto-char (point-min))
+      (while (re-search-forward mail-bad-\.-pattern nil t)
+        (replace-match "\\1 \\2"))
+
+      ;; Skip any initial garbage.
+      (goto-char (point-min))
+      (skip-chars-forward mail-non-begin-name-chars)
+      (skip-chars-backward "& \"")
+      (narrow-to-region (point) (point-max))
+      
+      (catch 'stop
+        (while t
+          (skip-chars-forward mail-whitespace)
+          
+          (cond
+           
+           ;; Delete title
+           ((and (eq word-count 0)
+                 (looking-at mail-full-name-prefixes))
+            (goto-char (match-end 0))
+            (narrow-to-region (point) (point-max)))
+           
+           ;; Stop after name suffix
+           ((and (>= word-count 2)
+                 (looking-at mail-full-name-suffix-pattern))
+            (skip-chars-backward mail-whitespace)
+            (setq suffix-flag (point))
+            (if (eq ?, (following-char))
+                (forward-char 1)
+              (insert ?,))
+            ;; Enforce at least one space after comma
+            (or (eq mail-space-char (following-char))
+                (insert mail-space-char))
+            (skip-chars-forward mail-whitespace)
+            (cond ((memq (following-char) '(?j ?J ?s ?S))
+                   (capitalize-word 1)
+                   (if (eq (following-char) ?.)
+                       (forward-char 1)
+                     (insert ?.)))
+                  (t
+                   (upcase-word 1)))
+            (setq word-count (1+ word-count))
+            (throw 'stop t))
+           
+           ;; Handle SCA names
+           ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As"
+            (setq word-count 0)
+            (goto-char (match-beginning 1))
+            (narrow-to-region (point) (point-max)))
+           
+           ;; Various stopping points
+           ((or
+             ;; Stop before ALL CAPS acronyms, if preceded by mixed-case or
+             ;; lowercase words.  Eg. XT-DEM.
+             (and (>= word-count 2)
+                  (or mixed-case-flag lower-case-flag)
+                  (looking-at mail-weird-acronym-pattern)
+                  (not (looking-at mail-roman-numeral-pattern)))
+             ;; Stop before 4-or-more letter lowercase words preceded by
+             ;; mixed case or uppercase words.
+             (and (>= word-count 2)
+                  (or upper-case-flag mixed-case-flag)
+                  (looking-at "[a-z][a-z][a-z][a-z]+\\b"))
+             ;; Stop before trailing alternative address
+             (looking-at mail-alternative-address-pattern)
+             ;; Stop before trailing comment not introduced by comma
+             (looking-at mail-trailing-comment-start-pattern)
+             ;; Stop before telephone numbers
+             (looking-at mail-telephone-extension-pattern))
+            (throw 'stop t))
+           
+           ;; Check for initial last name followed by comma
+           ((and (eq ?, (following-char))
+                 (eq word-count 1))
+            (forward-char 1)
+            (setq last-name-comma-flag t)
+            (or (eq mail-space-char (following-char))
+                (insert mail-space-char)))
+           
+           ;; Stop before trailing comma-separated comment
+           ((eq ?, (following-char))
+            (throw 'stop t))
+           
+           ;; Delete parenthesized/quoted comment/nickname
+           ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
+            (setq comment-beg (point))
+            (set-syntax-table address-text-comment-syntax-table)
+            (cond ((memq (following-char) '(?\' ?\`))
+                   (if (eq ?\' (following-char))
+                       (forward-char 1))
+                   (or (search-forward "'" nil t)
+                       (delete-char 1)))
+                  (t
+                   (or (safe-move-sexp 1)
+                       (goto-char (point-max)))))
+            (set-syntax-table address-text-syntax-table)
+            (setq comment-end (point))
+            (cond
+             ;; Handle case of entire name being quoted
+             ((and (eq word-count 0)
+                   (looking-at " *\\'")
+                   (>= (- comment-end comment-beg) 2))
+              (narrow-to-region (1+ comment-beg) (1- comment-end))
+              (goto-char (point-min)))
+             (t
+              ;; Handle case of quoted initial
+              (if (and (or (= 3 (- comment-end comment-beg))
+                           (and (= 4 (- comment-end comment-beg))
+                                (eq ?. (char-after (+ 2 comment-beg)))))
+                       (not (looking-at " *\\'")))
+                  (setq initial (char-after (1+ comment-beg)))
+                (setq initial nil))
+              (delete-region comment-beg comment-end)
+              (if initial
+                  (insert initial ". ")))))
+           
+           ;; Delete ham radio call signs
+           ((looking-at mail-ham-call-sign-pattern)
+            (delete-region (match-beginning 0) (match-end 0)))
+           
+           ;; Handle & substitution
+           ;; TODO: remember to disable middle initial guessing
+           ((and (or (bobp)
+                     (eq mail-space-char (preceding-char)))
+                 (looking-at "&\\( \\|\\'\\)"))
+            (delete-char 1)
+            (capitalize-region
+             (point)
+             (progn
+               (insert-buffer-substring canonicalization-buffer
+                                        mbox-beg mbox-end)
+               (point))))
+           
+           ;; Fixup initials
+           ((looking-at mail-initial-pattern)
+            (or (eq (following-char) (upcase (following-char)))
+                (setq lower-case-flag t))
+            (forward-char 1)
+            (if (eq ?. (following-char))
+                (forward-char 1)
+              (insert ?.))
+            (or (eq mail-space-char (following-char))
+                (insert mail-space-char))
+            (setq word-count (1+ word-count)))
+           
+           ;; Regular name words
+           ((looking-at mail-name-pattern)
+            (setq beg (point))
+            (setq end (match-end 0))
+            (set (if (re-search-forward "[a-z]" end t)
+                     (if (progn
+                           (goto-char beg)
+                           (re-search-forward "[A-Z]" end t))
+                         'mixed-case-flag
+                       'lower-case-flag)
+                   'upper-case-flag) t)
+            (goto-char end)
+            (setq word-count (1+ word-count)))
+
+           (t
+            (throw 'stop t)))))
+      
+      (narrow-to-region (point-min) (point))
+
+      ;; Delete trailing word followed immediately by .
+      (cond ((not suffix-flag)
+             (goto-char (point-min))
+             (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t)
+                 (narrow-to-region (point-min) (match-beginning 0)))))
+      
+      ;; If last name first put it at end (but before suffix)
+      (cond (last-name-comma-flag
+             (goto-char (point-min))
+             (search-forward ",")
+             (setq end (1- (point)))
+             (goto-char (or suffix-flag (point-max)))
+             (or (eq mail-space-char (preceding-char))
+                 (insert mail-space-char))
+             (insert-buffer-substring (current-buffer) (point-min) end)
+             (narrow-to-region (1+ end) (point-max))))
+      
+      (goto-char (point-max))
+      (skip-chars-backward mail-non-end-name-chars)
+      (if (eq ?. (following-char))
+          (forward-char 1))
+      (narrow-to-region (point)
+                        (progn
+                          (goto-char (point-min))
+                          (skip-chars-forward mail-non-begin-name-chars)
+                          (point)))
+      
+      ;; Compress whitespace
+      (goto-char (point-min))
+      (while (re-search-forward "[ \t\n]+" nil t)
+        (replace-match " "))
+
+      (buffer-substring (point-min) (point-max))
+
+      )))
+
+;; The country names are just in there for show right now, and because
+;; Jamie thought it would be neat.  They aren't used yet.
+
+;; Keep in mind that the country abbreviations follow ISO-3166.  There is
+;; a U.S. FIPS that specifies a different set of two-letter country
+;; abbreviations.
+
+;; TODO: put this in its own obarray, instead of cluttering up the main
+;; symbol table with junk.
+
+(mapcar
+ (function
+  (lambda (x)
+    (if (symbolp x)
+        (put x 'domain-name t)
+      (put (car x) 'domain-name (nth 1 x)))))
+ '((ag "Antigua")
+   (ar "Argentina")                     ; Argentine Republic
+   arpa                                 ; Advanced Projects Research Agency
+   (at "Austria")                       ; The Republic of _
+   (au "Australia")
+   (bb "Barbados")
+   (be "Belgium")                       ; The Kingdom of _
+   (bg "Bulgaria")
+   bitnet                               ; Because It's Time NET
+   (bo "Bolivia")                       ; Republic of _
+   (br "Brazil")                        ; The Federative Republic of _
+   (bs "Bahamas")
+   (bz "Belize")
+   (ca "Canada")
+   (ch "Switzerland")                   ; The Swiss Confederation
+   (cl "Chile")                         ; The Republic of _
+   (cn "China")                         ; The People's Republic of _
+   (co "Columbia")
+   com                                  ; Commercial
+   (cr "Costa Rica")                    ; The Republic of _
+   (cs "Czechoslovakia")
+   (de "Germany")
+   (dk "Denmark")
+   (dm "Dominica")
+   (do "Dominican Republic")            ; The _
+   (ec "Ecuador")                       ; The Republic of _
+   edu                                  ; Educational
+   (eg "Egypt")                         ; The Arab Republic of _
+   (es "Spain")                         ; The Kingdom of _
+   (fi "Finland")                       ; The Republic of _
+   (fj "Fiji")
+   (fr "France")
+   gov                                  ; Government (U.S.A.)
+   (gr "Greece")                        ; The Hellenic Republic
+   (hk "Hong Kong")
+   (hu "Hungary")                       ; The Hungarian People's Republic (???)
+   (ie "Ireland")
+   (il "Israel")                        ; The State of _
+   (in "India")                         ; The Republic of _
+   int                                  ; something British, don't know what
+   (is "Iceland")                       ; The Republic of _
+   (it "Italy")                         ; The Italian Republic
+   (jm "Jamaica")
+   (jp "Japan")
+   (kn "St. Kitts and Nevis")
+   (kr "South Korea")
+   (lc "St. Lucia")
+   (lk "Sri Lanka")                    ; The Democratic Socialist Republic of _
+   mil                                  ; Military (U.S.A.)
+   (mx "Mexico")                        ; The United Mexican States
+   (my "Malaysia")                      ; changed to Myanmar????
+   (na "Namibia")
+   nato                                 ; North Atlantic Treaty Organization
+   net                                  ; Network
+   (ni "Nicaragua")                     ; The Republic of _
+   (nl "Netherlands")                   ; The Kingdom of the _
+   (no "Norway")                        ; The Kingdom of _
+   (nz "New Zealand")
+   org                                  ; Organization
+   (pe "Peru")
+   (pg "Papua New Guinea")
+   (ph "Philippines")                   ; The Republic of the _
+   (pl "Poland")
+   (pr "Puerto Rico")
+   (pt "Portugal")                      ; The Portugese Republic
+   (py "Paraguay")
+   (se "Sweden")                        ; The Kingdom of _
+   (sg "Singapore")                     ; The Republic of _
+   (sr "Suriname")
+   (su "Soviet Union")
+   (th "Thailand")                      ; The Kingdom of _
+   (tn "Tunisia")
+   (tr "Turkey")                        ; The Republic of _
+   (tt "Trinidad and Tobago")
+   (tw "Taiwan")
+   (uk "United Kingdom")                ; The _ of Great Britain
+   unter-dom                            ; something German
+   (us "U.S.A.")                        ; The United States of America
+   uucp                                 ; Unix to Unix CoPy
+   (uy "Uruguay")                       ; The Eastern Republic of _
+   (vc "St. Vincent and the Grenadines")
+   (ve "Venezuela")                     ; The Republic of _
+   (yu "Yugoslavia")                    ; The Socialist Federal Republic of _
+   ;; Also said to be Zambia ...
+   (za "South Africa")                  ; The Republic of _ (why not Zaire???)
+   (zw "Zimbabwe")                      ; Republic of _
+   ))
+;; fipnet
+
+
+;; Code for testing.
+
+(defun time-extract ()
+  (let (times list)
+    (setq times (cons (current-time-string) times)
+          list problem-address-alist)
+    (while list
+      (mail-extract-address-components (car (car list)))
+      (setq list (cdr list)))
+    (setq times (cons (current-time-string) times))
+    (nreverse times)))
+
+(defun test-extract (&optional starting-point)
+  (interactive)
+  (set-buffer (get-buffer-create "*Testing*"))
+  (erase-buffer)
+  (sit-for 0)
+  (mapcar 'test-extract-internal
+          (if starting-point
+              (memq starting-point problem-address-alist)
+             problem-address-alist)))
+
+(defvar failed-item)
+(defun test-extract-internal (item)
+  (setq failed-item item)
+  (let* ((address (car item))
+         (correct-name (nth 1 item))
+         (correct-canon (nth 2 item))
+         (result (mail-extract-address-components address))
+         (name (car result))
+         (canon (nth 1 result))
+         (name-correct (or (null correct-name)
+                           (string-equal (downcase correct-name)
+                                         (downcase name))))
+         (canon-correct (or (null correct-canon)
+                            (string-equal correct-canon canon))))
+    (cond ((not (and name-correct canon-correct))
+           (pop-to-buffer "*Testing*")
+           (select-window (get-buffer-window (current-buffer)))
+           (goto-char (point-max))
+           (insert "Address: " address "\n")
+           (if (not name-correct)
+               (insert " Correct Name:  [" correct-name
+                       "]\; Result: [" name "]\n"))
+           (if (not canon-correct)
+               (insert " Correct Canon: [" correct-canon
+                       "]\; Result: [" canon "]\n"))
+           (insert "\n")
+           (sit-for 0))))
+  (setq failed-item nil))
+
+(defun test-continue-extract ()
+  (interactive)
+  (test-extract failed-item))
+
+
+;; Assorted junk.
+
+;;      warsaw@nlm.nih.gov (A Bad Dude -- Barry Warsaw)
+
+;;'(from
+;;  reply-to
+;;  return-path
+;;  x-uucp-from
+;;  sender
+;;  resent-from
+;;  resent-sender
+;;  resent-reply-to)
+
+;;; mail-extr.el ends here
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
new file mode 100644
index 00000000000..4f7d314773e
--- /dev/null
+++ b/lisp/progmodes/make-mode.el
@@ -0,0 +1,1043 @@
+;;; makefile.el --- makefile editing commands for Emacs
+
+;; Author: Thomas Neumann <tom@smart.bo.open.de>
+;; Adapted-By: ESR
+;; Keywords: unix tools
+
+;; $Id: makefile.el,v 1.7.1.17 1992/07/15 20:05:15 tom Exp tom $
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+(provide 'makefile)
+
+;;; ------------------------------------------------------------
+;;; Configureable stuff
+;;; ------------------------------------------------------------
+
+(defvar makefile-mode-name "makefile"
+  "The \"pretty name\" of makefile-mode, as it
+appears in the modeline.")
+
+(defvar makefile-browser-buffer-name "*Macros and Targets*"
+  "Name of the macro- and target browser buffer.")
+
+(defvar makefile-target-colon ":"
+  "The string that gets appended to all target names
+inserted by makefile-insert-target.
+\":\" or \"::\" are quite common values.")
+
+(defvar makefile-macro-assign " = "
+  "The string that gets appended to all macro names
+inserted by makefile-insert-macro.
+The normal value should be \" = \", since this is what
+standard make expects. However, newer makes such as dmake
+allow a larger variety of different macro assignments, so you
+might prefer to use \" += \" or \" := \" .")
+
+(defvar makefile-use-curly-braces-for-macros-p nil
+  "Set this variable to a non-nil value if you prefer curly braces
+in macro-references, so it looks like ${this}. A value of nil
+will cause makefile-mode to use parantheses, making macro references
+look like $(this) .")
+
+(defvar makefile-tab-after-target-colon t
+  "If you want a TAB (instead of a space) to be appended after the
+target colon, then set this to a non-nil value.")
+
+(defvar makefile-browser-leftmost-column 10
+  "Number of blanks to the left of the browser selection mark.")
+
+(defvar makefile-browser-cursor-column 10
+  "Column in which the cursor is positioned when it moves
+up or down in the browser.")
+
+(defvar makefile-browser-selected-mark "+  "
+  "String used to mark selected entries in the browser.")
+
+(defvar makefile-browser-unselected-mark "   "
+  "String used to mark unselected entries in the browser.")
+
+(defvar makefile-browser-auto-advance-after-selection-p t
+  "If this variable is set to a non-nil value the cursor
+will automagically advance to the next line after an item
+has been selected in the browser.")
+
+(defvar makefile-find-file-autopickup-p t
+  "If this variable is set to a non-nil value then finding a file in
+a makefile-mode buffer will cause an automatic initial pickup of
+all macros and targets from the found file.")
+
+(defvar makefile-pickup-everything-picks-up-filenames-p nil
+  "If this variable is set to a non-nil value then
+makefile-pickup-everything also picks up filenames as targets
+(i.e. it calls makefile-find-filenames-as-targets), otherwise
+filenames are omitted.")
+
+(defvar makefile-cleanup-continuations-p t
+  "If this variable is set to a non-nil value then makefile-mode
+will assure that no line in the file ends with a backslash
+(the continuation character) followed by any whitespace.
+This is done by silently removing the trailing whitespace, leaving
+the backslash itself intact.
+IMPORTANT: Please note that enabling this option causes makefile-mode
+to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'.")
+
+(defvar makefile-browser-hook '()
+  "A function or list of functions to be called just before the
+browser is entered. This is executed in the makefile buffer, so
+you can for example run a makefile-pickup-everything automatically.")
+
+;;
+;; Special targets for DMake, Sun's make ...
+;; 
+(defvar makefile-special-targets-list
+  '(("DEFAULT")      ("DONE")        ("ERROR")        ("EXPORT")
+    ("FAILED")       ("GROUPEPILOG") ("GROUPPROLOG")  ("IGNORE")
+    ("IMPORT")       ("INCLUDE")     ("INCLUDEDIRS")  ("INIT")
+    ("KEEP_STATE")   ("MAKEFILES")   ("MAKE_VERSION") ("NO_PARALLEL")
+    ("PARALLEL")     ("PHONY")       ("PRECIOUS")     ("REMOVE")
+    ("SCCS_GET")     ("SILENT")      ("SOURCE")       ("SUFFIXES")
+    ("WAIT")         ("c.o")         ("C.o")          ("m.o")
+    ("el.elc")       ("y.c")         ("s.o"))
+  "List of special targets. You will be offered to complete
+on one of those in the minibuffer whenever you enter a \".\"
+at the beginning of a line in makefile-mode.")
+
+(defvar makefile-runtime-macros-list
+  '(("@") ("&") (">") ("<") ("*") ("^") ("?") ("%"))
+  "List of macros that are resolved by make at runtime.
+If you insert a macro reference using makefile-insert-macro-ref, the name
+of the macro is checked against this list. If it can be found its name will
+not be enclosed in { } or ( ).")
+
+(defconst makefile-dependency-regex
+  "^[^ \t#:]+\\([ \t]+[^ \t#:]+\\)*[ \t]*:\\($\\|\\([^=].*$\\)\\)"
+  "Regex used to find dependency lines in a makefile.")
+
+(defconst makefile-macroassign-regex
+  "^[^ \t][^:#=]*[\\*:\\+]?:?=.*$"
+  "Regex used to find macro assignment lines in a makefile.")
+
+(defconst makefile-ignored-files-in-pickup-regex
+  "\\(^\\..*\\)\\|\\(.*~$\\)\\|\\(.*,v$\\)"
+  "Regex for filenames that will NOT be included in the target list.")
+
+;;; ------------------------------------------------------------
+;;; The following configurable variables are used in the
+;;; up-to-date overview .
+;;; The standard configuration assumes that your `make' programm
+;;; can be run in question/query mode using the `-q' option, this
+;;; means that the command
+;;;
+;;;    make -q foo
+;;;
+;;; should return an exit status of zero if the target `foo' is
+;;; up to date and a nonzero exit status otherwise.
+;;; Many makes can do this although the docs/manpages do not mention
+;;; it. Try it with your favourite one. GNU make and Dennis Vaduras
+;;; DMake have no problems.
+;;; Set the variable `makefile-brave-make' to the name of the
+;;; make utility that does this on your system.
+;;; To understand what this is all about see the function defintion
+;;; of `makefile-query-by-make-minus-q' .
+;;; ------------------------------------------------------------
+
+(defvar makefile-brave-make "gmake"
+  "A make that can handle the \'-q\' option.")
+
+(defvar makefile-query-one-target-method 'makefile-query-by-make-minus-q
+  "A function symbol [one that can be used as the first argument to
+funcall] that provides a function that must conform to the following
+interface:
+
+* As its first argument, it must accept the name of the target to
+  be checked, as a string.
+
+* As its second argument, it may accept the name of a makefile
+  as a string. Depending on what you\'re going to do you may
+  not need this.
+
+* It must return the integer value 0 (zero) if the given target
+  should be considered up-to-date in the context of the given
+  makefile, any nonzero integer value otherwise.")
+
+(defvar makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*"
+  "Name of the Up-to-date overview buffer.")
+
+(defvar makefile-target-needs-rebuild-mark "  .. NEEDS REBUILD"
+  "A string that is appended to the target name in the up-to-date
+overview if that target is considered to require a rebuild.")
+
+(defvar makefile-target-up-to-date-mark    "  .. is up to date"
+  "A string that is appenden to the target name in the up-to-date
+overview if that target is considered up-to-date.")
+
+;;; --- end of up-to-date-overview configuration ------------------
+
+
+(defvar makefile-mode-map nil
+  "The keymap that is used in makefile-mode.")
+(if makefile-mode-map
+    ()
+  (setq makefile-mode-map (make-sparse-keymap))
+  ;; set up the keymap
+  (define-key makefile-mode-map "$"        'makefile-insert-macro-ref)
+  (define-key makefile-mode-map "\C-c:"    'makefile-insert-target-ref)
+  (define-key makefile-mode-map ":"        'makefile-electric-colon)
+  (define-key makefile-mode-map "="        'makefile-electric-equal)
+  (define-key makefile-mode-map "."        'makefile-electric-dot)
+  (define-key makefile-mode-map "\C-c\C-t" 'makefile-pickup-targets)
+  (define-key makefile-mode-map "\C-c\C-m" 'makefile-pickup-macros)
+  (define-key makefile-mode-map "\C-c\C-f" 'makefile-pickup-filenames-as-targets)
+  (define-key makefile-mode-map "\C-c\C-0" 'makefile-forget-everything)
+  (define-key makefile-mode-map "\C-c0"    'makefile-forget-everything)  
+  (define-key makefile-mode-map "\C-c\C-b" 'makefile-switch-to-browser)
+  (define-key makefile-mode-map "\C-c\C-p" 'makefile-pickup-everything)
+  (define-key makefile-mode-map "\C-c\C-u" 'makefile-create-up-to-date-overview)
+  (define-key makefile-mode-map "\C-c\C-i" 'makefile-insert-gmake-function)
+  (define-key makefile-mode-map "\M-p"     'makefile-previous-dependency)
+  (define-key makefile-mode-map "\M-n"     'makefile-next-dependency))  
+
+(defvar makefile-browser-map nil
+  "The keymap that is used in the macro- and target browser.")
+(if makefile-browser-map
+    ()
+  (setq makefile-browser-map (make-sparse-keymap))
+  (define-key makefile-browser-map "n"    'makefile-browser-next-line)
+  (define-key makefile-browser-map "\C-n" 'makefile-browser-next-line)    
+  (define-key makefile-browser-map "p"    'makefile-browser-previous-line)
+  (define-key makefile-browser-map "\C-p" 'makefile-browser-previous-line)
+  (define-key makefile-browser-map " "    'makefile-browser-toggle)
+  (define-key makefile-browser-map "i"    'makefile-browser-insert-selection)
+  (define-key makefile-browser-map "I"    'makefile-browser-insert-selection-and-quit)  
+  (define-key makefile-browser-map "\C-c\C-m" 'makefile-browser-insert-continuation)
+  (define-key makefile-browser-map "q"    'makefile-browser-quit)
+  ;; disable horizontal movement
+  (define-key makefile-browser-map "\C-b" 'undefined)
+  (define-key makefile-browser-map "\C-f" 'undefined))  
+
+
+(defvar makefile-mode-syntax-table nil
+  "The syntax-table used in makefile mode.")
+(if makefile-mode-syntax-table
+    ()
+  (setq makefile-mode-syntax-table (make-syntax-table))
+  (modify-syntax-entry ?\( "()    " makefile-mode-syntax-table)
+  (modify-syntax-entry ?\) ")(    " makefile-mode-syntax-table)
+  (modify-syntax-entry ?\[ "(]    " makefile-mode-syntax-table)
+  (modify-syntax-entry ?\] "([    " makefile-mode-syntax-table)
+  (modify-syntax-entry ?\{ "(}    " makefile-mode-syntax-table)  
+  (modify-syntax-entry ?\} "){    " makefile-mode-syntax-table)
+  (modify-syntax-entry ?#  "<     " makefile-mode-syntax-table)
+  (modify-syntax-entry ?\n ">     " makefile-mode-syntax-table))
+  
+  
+;;; ------------------------------------------------------------
+;;; Internal variables.
+;;; You don't need to configure below this line.
+;;; ------------------------------------------------------------
+
+(defvar makefile-target-table nil
+  "Table of all targets that have been inserted in
+this Makefile buffer using makefile-insert-target or picked up
+using makefile-pickup-targets.")
+
+(defvar makefile-macro-table nil
+  "Table of all macros that have been iserted in
+this Makefile buffer using makefile-insert-macro or picked up
+using makefile-pickup-macros.")
+
+(defvar makefile-browser-client
+  "A buffer in makefile-mode that is currently using the browser.")
+
+(defvar makefile-browser-selection-vector nil)
+
+(defvar makefile-mode-hook '())
+
+(defconst makefile-gnumake-functions-alist
+
+  '(
+    ;; Text functions
+    ("subst" "From" "To" "In")
+    ("patsubst" "Pattern" "Replacement" "In")
+    ("strip" "Text")
+    ("findstring" "Find what" "In")
+    ("filter" "Pattern" "Text")
+    ("filter-out" "Pattern" "Text")
+    ("sort" "List")
+    ;; Filename functions
+    ("dir" "Names")
+    ("notdir" "Names")
+    ("suffix" "Names")
+    ("basename" "Names")
+    ("addsuffix" "Suffix" "Names")
+    ("join" "List 1" "List 2")
+    ("word" "Index" "Text")
+    ("words" "Text")
+    ("firstword" "Text")
+    ("wildcard" "Pattern")
+    ;; Misc functions
+    ("foreach" "Variable" "List" "Text")
+    ("origin" "Variable")
+    ("shell" "Command"))
+  "A list of GNU make 3.62 function names associated with
+the prompts for each function.
+This is used in the function makefile-insert-gmake-function .")
+
+
+;;; ------------------------------------------------------------
+;;; The mode function itself.
+;;; ------------------------------------------------------------
+
+(defun makefile-mode ()
+  "Major mode for editing Makefiles.
+Calling this function invokes the function(s) \"makefile-mode-hook\" before
+doing anything else.
+
+\\{makefile-mode-map}
+
+In the browser, use the following keys:
+
+\\{makefile-browser-map}
+
+makefile-mode can be configured by modifying the following
+variables:
+
+makefile-mode-name:
+    The \"pretty name\" of makefile-mode, as it
+    appears in the modeline.
+
+makefile-browser-buffer-name:
+    Name of the macro- and target browser buffer.
+
+makefile-target-colon:
+    The string that gets appended to all target names
+    inserted by makefile-insert-target.
+    \":\" or \"::\" are quite common values.
+
+makefile-macro-assign:
+   The string that gets appended to all macro names
+   inserted by makefile-insert-macro.
+   The normal value should be \" = \", since this is what
+   standard make expects. However, newer makes such as dmake
+   allow a larger variety of different macro assignments, so you
+   might prefer to use \" += \" or \" := \" .
+
+makefile-tab-after-target-colon:
+   If you want a TAB (instead of a space) to be appended after the
+   target colon, then set this to a non-nil value.
+
+makefile-browser-leftmost-column:
+   Number of blanks to the left of the browser selection mark.
+
+makefile-browser-cursor-column:
+   Column in which the cursor is positioned when it moves
+   up or down in the browser.
+
+makefile-browser-selected-mark:
+   String used to mark selected entries in the browser.
+
+makefile-browser-unselected-mark:
+   String used to mark unselected entries in the browser.
+
+makefile-browser-auto-advance-after-selection-p:
+   If this variable is set to a non-nil value the cursor
+   will automagically advance to the next line after an item
+   has been selected in the browser.
+
+makefile-find-file-autopickup-p:
+   If this variable is set to a non-nil value then finding a file in
+   a makefile-mode buffer will cause an automatic initial pickup of
+   all macros and targets from the found file.
+
+makefile-pickup-everything-picks-up-filenames-p:
+   If this variable is set to a non-nil value then
+   makefile-pickup-everything also picks up filenames as targets
+   (i.e. it calls makefile-find-filenames-as-targets), otherwise
+   filenames are omitted.
+
+makefile-cleanup-continuations-p:
+   If this variable is set to a non-nil value then makefile-mode
+   will assure that no line in the file ends with a backslash
+   (the continuation character) followed by any whitespace.
+   This is done by silently removing the trailing whitespace, leaving
+   the backslash itself intact.
+   IMPORTANT: Please note that enabling this option causes makefile-mode
+   to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'.
+
+makefile-browser-hook:
+   A function or list of functions to be called just before the
+   browser is entered. This is executed in the makefile buffer, so
+   you can for example run a makefile-pickup-everything automatically.
+
+makefile-special-targets-list:
+   List of special targets. You will be offered to complete
+   on one of those in the minibuffer whenever you enter a \".\"
+   at the beginning of a line in makefile-mode."
+  (interactive)
+  (kill-all-local-variables)
+  (if (not (memq 'makefile-find-file-autopickup find-file-hooks))
+      (setq find-file-hooks
+            (append find-file-hooks (list 'makefile-find-file-autopickup))))
+  (if (not (memq 'makefile-cleanup-continuations write-file-hooks))
+      (setq write-file-hooks
+            (append write-file-hooks (list 'makefile-cleanup-continuations))))
+  (make-variable-buffer-local 'makefile-target-table)
+  (make-variable-buffer-local 'makefile-macro-table)
+  (makefile-forget-all-macros)
+  (makefile-forget-all-targets)
+  (setq comment-start "#")
+  (setq comment-end "")
+  (setq comment-start-skip "#[ \t]*")
+  ;; become the current major mode
+  (setq major-mode 'makefile-mode)
+  (setq mode-name makefile-mode-name)
+  ;; activate keymap
+  (use-local-map makefile-mode-map)
+  (set-syntax-table makefile-mode-syntax-table)
+  (run-hooks 'makefile-mode-hook))  
+
+
+(defun makefile-find-file-autopickup ()
+  (if (eq major-mode 'makefile-mode)
+      (if makefile-find-file-autopickup-p
+          (makefile-pickup-everything))))
+
+(defun makefile-next-dependency ()
+  "Move (point) to the beginning of the next dependency line
+below the current position of (point)."
+  (interactive)
+  (let ((here (point)))
+    (end-of-line)
+    (if (re-search-forward makefile-dependency-regex (point-max) t)
+        (progn (beginning-of-line) t)   ; indicate success
+      (goto-char here) nil)))
+      
+(defun makefile-previous-dependency ()
+  "Move (point) to the beginning of the next dependency line
+above the current position of (point)."
+  (interactive)
+  (let ((here (point)))
+    (beginning-of-line)
+    (if (re-search-backward makefile-dependency-regex (point-min) t)
+        (progn (beginning-of-line) t)   ; indicate success
+      (goto-char here) nil)))
+
+
+(defun makefile-electric-dot ()
+  "At (bol), offer completion on makefile-special-targets-list.
+Anywhere else just insert a dot."
+  (interactive)
+  (if (bolp)
+      (makefile-insert-special-target)
+    (insert ".")))
+
+
+(defun makefile-insert-special-target ()
+  "Offer completion on makefile-special-targets-list and insert
+the result at (point)."
+  (interactive)
+  (let
+      ((special-target
+       (completing-read "Special target: "
+                        makefile-special-targets-list nil nil nil)))
+    (if (zerop (length special-target))
+        ()
+      (insert (format ".%s:" special-target))
+      (makefile-forward-after-target-colon))))
+
+
+(defun makefile-electric-equal ()
+  "At (bol) do makefile-insert-macro. Anywhere else just
+self-insert."
+  (interactive)
+  (if (bolp)
+      (call-interactively 'makefile-insert-macro)
+    (insert "=")))
+
+(defun makefile-insert-macro (macro-name)
+  "Prepare definition of a new macro."
+  (interactive "sMacro Name: ")
+  (if (not (zerop (length macro-name)))
+      (progn
+        (beginning-of-line)
+        (insert (format "%s%s" macro-name makefile-macro-assign))
+        (makefile-remember-macro macro-name))))
+
+
+(defun makefile-insert-macro-ref (macro-name)
+  "Offer completion on a list of known macros, then
+insert complete macro-ref at (point) ."
+  (interactive
+   (list
+    (completing-read "Refer to macro: " makefile-macro-table nil nil nil)))
+   (if (not (zerop (length macro-name)))
+       (if (assoc macro-name makefile-runtime-macros-list)
+           (insert (format "$%s " macro-name))
+         (insert (makefile-format-macro-ref macro-name) " "))))
+
+
+(defun makefile-insert-target (target-name)
+  "Prepare definition of a new target (dependency line)."
+  (interactive "sTarget: ")
+  (if (not (zerop (length target-name)))
+      (progn
+        (beginning-of-line)
+        (insert (format "%s%s" target-name makefile-target-colon))
+        (makefile-forward-after-target-colon)
+        (end-of-line)
+        (makefile-remember-target target-name))))
+
+
+(defun makefile-insert-target-ref (target-name)
+  "Offer completion on a list of known targets, then
+insert complete target-ref at (point) ."
+  (interactive
+   (list
+    (completing-read "Refer to target: " makefile-target-table nil nil nil)))
+   (if (not (zerop (length target-name)))
+       (progn
+         (insert (format "%s " target-name)))))
+
+(defun makefile-electric-colon ()
+  "At (bol) defines a new target, anywhere else just self-insert ."
+  (interactive)
+  (if (bolp)
+      (call-interactively 'makefile-insert-target)
+    (insert ":")))
+
+
+;;; ------------------------------------------------------------
+;;; Extracting targets and macros from an existing makefile
+;;; ------------------------------------------------------------
+
+(defun makefile-pickup-targets ()
+  "Scan a buffer that contains a makefile for target definitions (dependencies)
+and add them to the list of known targets."
+  (interactive)
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward makefile-dependency-regex (point-max) t)
+      (makefile-add-this-line-targets))))
+;      (forward-line 1))))
+
+(defun makefile-add-this-line-targets ()
+  (save-excursion
+    (beginning-of-line)
+    (let ((done-with-line nil))
+      (while (not done-with-line)
+        (skip-chars-forward " \t")
+        (if (not (setq done-with-line (or (eolp)
+                                          (char-equal (char-after (point)) ?:))))
+            (progn
+              (let* ((start-of-target-name (point))
+                     (target-name
+                      (progn
+                        (skip-chars-forward "^ \t:#")
+                        (buffer-substring start-of-target-name (point)))))
+                (if (makefile-remember-target target-name)
+                    (message "Picked up target \"%s\"" target-name)))))))))
+
+
+(defun makefile-pickup-macros ()
+  "Scan a buffer that contains a makefile for macro definitions
+and add them to the list of known macros."
+  (interactive)
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward makefile-macroassign-regex (point-max) t)
+      (makefile-add-this-line-macro)
+      (forward-line 1))))
+
+(defun makefile-add-this-line-macro ()
+  (save-excursion
+    (beginning-of-line)
+    (skip-chars-forward " \t")
+    (if (not (eolp))
+        (let* ((start-of-macro-name (point))
+               (macro-name (progn
+                             (skip-chars-forward "^ \t:#=*")
+                             (buffer-substring start-of-macro-name (point)))))
+          (if (makefile-remember-macro macro-name)
+              (message "Picked up macro \"%s\"" macro-name))))))
+
+
+(defun makefile-pickup-everything ()
+  "Calls makefile-pickup-targets and makefile-pickup-macros.
+See their documentation for what they do."
+  (interactive)
+  (makefile-pickup-macros)
+  (makefile-pickup-targets)
+  (if makefile-pickup-everything-picks-up-filenames-p
+      (makefile-pickup-filenames-as-targets)))
+
+
+(defun makefile-pickup-filenames-as-targets ()
+  "Scan the current directory for filenames, check each filename
+against makefile-ignored-files-in-pickup-regex and add all qualifying
+names to the list of known targets."
+  (interactive)
+  (let* ((dir (file-name-directory (buffer-file-name)))
+         (raw-filename-list (if dir
+                                (file-name-all-completions "" dir)
+                              (file-name-all-completions "" ""))))
+    (mapcar '(lambda (name)
+               (if (and (not (file-directory-p name))
+                        (not (string-match makefile-ignored-files-in-pickup-regex
+                                           name)))
+                   (if (makefile-remember-target name)
+                       (message "Picked up file \"%s\" as target" name))))
+            raw-filename-list)))
+
+;;; ------------------------------------------------------------
+;;; The browser window
+;;; ------------------------------------------------------------
+
+
+(defun makefile-browser-format-target-line (target selected)
+  (format
+   (concat (make-string makefile-browser-leftmost-column ?\ )
+           (if selected
+               makefile-browser-selected-mark
+             makefile-browser-unselected-mark)
+           "%s%s")
+   target makefile-target-colon))
+
+(defun makefile-browser-format-macro-line (macro selected)
+  (format
+   (concat (make-string makefile-browser-leftmost-column ?\ )
+           (if selected
+               makefile-browser-selected-mark
+             makefile-browser-unselected-mark)
+           (makefile-format-macro-ref macro))))
+
+(defun makefile-browser-fill (targets macros)
+  (setq buffer-read-only nil)
+  (goto-char (point-min))
+  (erase-buffer)
+  (mapconcat
+   (function
+    (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n")))
+   targets
+   "")
+  (mapconcat
+   (function
+    (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n")))
+   macros
+   "")
+  (sort-lines nil (point-min) (point-max))
+  (goto-char (1- (point-max)))
+  (delete-char 1)                       ; remove unnecessary newline at eob
+  (goto-char (point-min))
+  (forward-char makefile-browser-cursor-column)
+  (setq buffer-read-only t))
+  
+
+;;;
+;;; Moving up and down in the browser
+;;;
+
+(defun makefile-browser-next-line ()
+  "Move the browser selection cursor to the next line."
+  (interactive)
+  (if (not (makefile-last-line-p))
+      (progn
+        (forward-line 1)
+        (forward-char makefile-browser-cursor-column))))
+
+(defun makefile-browser-previous-line ()
+  "Move the browser selection cursor to the previous line."
+  (interactive)
+  (if (not (makefile-first-line-p))
+      (progn
+        (forward-line -1)
+        (forward-char makefile-browser-cursor-column))))
+
+;;;
+;;; Quitting the browser (returns to client buffer)
+;;;
+
+(defun makefile-browser-quit ()
+  "Leave the makefile-browser-buffer and return to the buffer
+from that it has been entered."
+  (interactive)
+  (let ((my-client makefile-browser-client))
+    (setq makefile-browser-client nil)  ; we quitted, so NO client!
+    (set-buffer-modified-p nil)
+    (kill-buffer (current-buffer))
+    (pop-to-buffer my-client)))
+
+;;;
+;;; Toggle state of a browser item
+;;;
+
+(defun makefile-browser-toggle ()
+  "Toggle the selection state of the browser item at the cursor position."
+  (interactive)
+  (let ((this-line (count-lines (point-min) (point))))
+    (setq this-line (max 1 this-line))
+    (makefile-browser-toggle-state-for-line this-line)
+    (goto-line this-line)
+    (setq buffer-read-only nil)
+    (beginning-of-line)
+    (if (makefile-browser-on-macro-line-p)
+        (let ((macro-name (makefile-browser-this-line-macro-name)))
+          (kill-line)
+          (insert
+           (makefile-browser-format-macro-line
+              macro-name
+              (makefile-browser-get-state-for-line this-line))))
+      (let ((target-name (makefile-browser-this-line-target-name)))
+        (kill-line)
+        (insert
+         (makefile-browser-format-target-line
+            target-name
+            (makefile-browser-get-state-for-line this-line)))))
+    (setq buffer-read-only t)
+    (beginning-of-line)
+    (forward-char makefile-browser-cursor-column)
+    (if makefile-browser-auto-advance-after-selection-p
+        (makefile-browser-next-line))))
+
+;;;
+;;; Making insertions into the client buffer
+;;;
+
+(defun makefile-browser-insert-continuation ()
+  "In the browser\'s client buffer, go to (end-of-line), insert a \'\\\'
+character, insert a new blank line, go to that line and indent by one TAB.
+This is most useful in the process of creating continued lines when 'sending' large
+dependencies from the browser to the client buffer.
+(point) advances accordingly in the client buffer."
+  (interactive)
+  (save-excursion
+    (set-buffer makefile-browser-client)
+    (end-of-line)
+    (insert "\\\n\t")))
+
+(defun makefile-browser-insert-selection ()
+  "Insert all browser-selected targets and/or macros in the browser\'s
+client buffer.
+Insertion takes place at (point)."
+  (interactive)
+  (save-excursion
+    (goto-line 1)
+    (let ((current-line 1))
+      (while (not (eobp))
+        (if (makefile-browser-get-state-for-line current-line)
+            (makefile-browser-send-this-line-item))
+        (forward-line 1)
+        (setq current-line (1+ current-line))))))
+
+(defun makefile-browser-insert-selection-and-quit ()
+  (interactive)
+  (makefile-browser-insert-selection)
+  (makefile-browser-quit))
+
+(defun makefile-browser-send-this-line-item ()
+  (if (makefile-browser-on-macro-line-p)
+      (save-excursion
+        (let ((macro-name (makefile-browser-this-line-macro-name)))
+          (set-buffer makefile-browser-client)
+          (insert (makefile-format-macro-ref macro-name) " ")))
+    (save-excursion
+      (let ((target-name (makefile-browser-this-line-target-name)))
+        (set-buffer makefile-browser-client)
+        (insert target-name " ")))))
+
+
+(defun makefile-browser-start-interaction ()
+  (use-local-map makefile-browser-map)
+  (setq buffer-read-only t))
+
+
+(defun makefile-browse (targets macros)
+  (interactive)
+  (if (zerop (+ (length targets) (length macros)))
+      (progn
+        (beep)
+        (message "No macros or targets to browse! Consider running 'makefile-pickup-everything\'"))
+    (let ((browser-buffer (get-buffer-create makefile-browser-buffer-name)))
+        (pop-to-buffer browser-buffer)
+        (make-variable-buffer-local 'makefile-browser-selection-vector)
+        (makefile-browser-fill targets macros)
+        (setq makefile-browser-selection-vector
+              (make-vector (+ (length targets) (length macros)) nil))
+        (makefile-browser-start-interaction))))
+  
+
+(defun makefile-switch-to-browser ()
+  (interactive)
+  (run-hooks 'makefile-browser-hook)
+  (setq makefile-browser-client (current-buffer))
+  (makefile-browse makefile-target-table makefile-macro-table))
+
+
+;;; ------------------------------------------------------------
+;;; Up-to-date overview buffer
+;;; ------------------------------------------------------------
+
+(defun makefile-create-up-to-date-overview ()
+  "Create a buffer containing an overview of the state of all
+known targets from the makefile that is currently being edited.
+Known targets are targets that are explicitly defined in that makefile;
+in other words, all targets that appear on the left hand side of a
+dependency in the makefile."
+  (interactive)
+  (if (y-or-n-p "Are you sure that the makefile being edited is consistent? ")
+      ;;
+      ;; The rest of this function operates on a temporary makefile, created by
+      ;; writing the current contents of the makefile buffer.
+      ;;
+      (let ((saved-target-table makefile-target-table)
+            (this-buffer (current-buffer))
+            (makefile-up-to-date-buffer
+             (get-buffer-create makefile-up-to-date-buffer-name))
+            (filename (makefile-save-temporary))
+            ;;
+            ;; Forget the target table because it may contain picked-up filenames
+            ;; that are not really targets in the current makefile.
+            ;; We don't want to query these, so get a new target-table with just the
+            ;; targets that can be found in the makefile buffer.
+            ;; The 'old' target table will be restored later.
+            ;;
+            (real-targets (progn
+                            (makefile-forget-all-targets)
+                            (makefile-pickup-targets)
+                            makefile-target-table)))
+
+        (set-buffer makefile-up-to-date-buffer)
+        (setq buffer-read-only nil)
+        (erase-buffer)
+        (makefile-query-targets filename real-targets)
+        (if (zerop (buffer-size))               ; if it did not get us anything
+            (progn
+              (kill-buffer (current-buffer))
+              (message "No overview created!")))
+        (set-buffer this-buffer)
+        (setq makefile-target-table saved-target-table)
+        (if (get-buffer makefile-up-to-date-buffer-name)
+            (progn
+              (pop-to-buffer (get-buffer makefile-up-to-date-buffer-name))
+              (sort-lines nil (point-min) (point-max))
+              (setq buffer-read-only t))))))
+      
+  
+
+(defun makefile-save-temporary ()
+  "Create a temporary file from the current makefile buffer."
+  (let ((filename (makefile-generate-temporary-filename)))
+    (write-region (point-min) (point-max) filename nil 0)
+    filename))                          ; return the filename
+
+(defun makefile-generate-temporary-filename ()
+  "Create a filename suitable for use in makefile-save-temporary.
+Be careful to allow brain-dead file systems (DOS, SYSV ...) to cope
+with the generated name !"
+  (let ((my-name (user-login-name))
+        (my-uid (int-to-string (user-uid))))
+    (concat "mktmp"
+          (if (> (length my-name) 3)
+              (substring my-name 0 3)
+            my-name)
+          "."
+          (if (> (length my-uid) 3)
+              (substring my-uid 0 3)
+            my-uid))))
+
+(defun makefile-query-targets (filename target-table)
+  "This function fills the up-to-date-overview-buffer.
+It checks each target in target-table using makefile-query-one-target-method
+and generates the overview, one line per target name."
+  (insert
+   (mapconcat '(lambda (item)
+                 (let ((target-name (car item)))
+                   (makefile-format-up-to-date-buffer-entry
+                    (funcall makefile-query-one-target-method
+                             target-name filename) target-name)))
+              target-table "\n"))
+  (goto-char (point-min))
+  (delete-file filename))               ; remove the tmpfile
+
+(defun makefile-query-by-make-minus-q (target &optional filename)
+  (not (zerop (call-process makefile-brave-make nil nil nil "-f" filename "-q" target))))
+
+(defun makefile-format-up-to-date-buffer-entry (needs-rebuild target)
+  (format "\t%s%s"
+          target
+          (if needs-rebuild
+              makefile-target-needs-rebuild-mark
+            makefile-target-up-to-date-mark)))
+
+
+;;; ------------------------------------------------------------
+;;; Continuation cleanup
+;;; ------------------------------------------------------------
+
+(defun makefile-cleanup-continuations ()
+  (if (eq major-mode 'makefile-mode)
+      (if (and makefile-cleanup-continuations-p
+               (not buffer-read-only))
+          (save-excursion
+            (goto-char (point-min))
+            (while (re-search-forward "\\\\[ \t]+$" (point-max) t)
+              (replace-match "\\" t t))))))
+
+;;; ------------------------------------------------------------
+;;; GNU make function support
+;;; ------------------------------------------------------------
+
+(defun makefile-insert-gmake-function ()
+  "This function is intended to help you using the numerous
+macro-like \'function calls\' of GNU make.
+It will ask you for the name of the function you wish to
+use (with completion), then, after you selected the function,
+it will prompt you for all required parameters.
+This function \'knows\' about the required parameters of every
+GNU make function and will use meaningfull prompts for the
+various args, making it much easier to take advantage of this
+powerfull GNU make feature."
+  (interactive)
+  (let* ((gm-function-name (completing-read
+                             "Function: "
+                             makefile-gnumake-functions-alist
+                             nil t nil))
+         (gm-function-prompts
+          (cdr (assoc gm-function-name makefile-gnumake-functions-alist))))
+    (if (not (zerop (length gm-function-name)))
+        (insert (makefile-format-macro-ref
+                 (concat gm-function-name " "
+                         (makefile-prompt-for-gmake-funargs
+                            gm-function-name gm-function-prompts)))
+                " "))))
+
+(defun makefile-prompt-for-gmake-funargs (function-name prompt-list)
+  (mapconcat
+   (function (lambda (one-prompt)
+               (read-string (format "[%s] %s: " function-name one-prompt) nil)))
+   prompt-list
+   ","))
+    
+
+
+;;; ------------------------------------------------------------
+;;; Utility functions
+;;; ------------------------------------------------------------
+
+(defun makefile-forget-all-targets ()
+  "Clear the target-table for this buffer."
+  (interactive)
+  (setq makefile-target-table '()))
+
+(defun makefile-forget-all-macros ()
+  "Clear the macro-table for this buffer."
+  (interactive)
+  (setq makefile-macro-table '()))
+
+
+(defun makefile-forget-everything ()
+  "Clear the macro-table AND the target-table for this buffer."
+  (interactive)
+  (if (y-or-n-p "Really forget all macro- and target information ? ")
+      (progn
+        (makefile-forget-all-targets)
+        (makefile-forget-all-macros)
+        (if (get-buffer makefile-browser-buffer-name)
+            (kill-buffer makefile-browser-buffer-name))
+        (message "Cleared macro- and target tables."))))
+
+(defun makefile-remember-target (target-name)
+  "Remember a given target if it is not already remembered for this buffer."
+  (if (not (zerop (length target-name)))
+      (if (not (assoc target-name makefile-target-table))
+          (setq makefile-target-table
+                (cons (list target-name) makefile-target-table)))))
+
+(defun makefile-remember-macro (macro-name)
+  "Remember a given macro if it is not already remembered for this buffer."
+  (if (not (zerop (length macro-name)))
+      (if (not (assoc macro-name makefile-macro-table))
+          (setq makefile-macro-table
+                (cons (list macro-name) makefile-macro-table)))))
+
+(defun makefile-forward-after-target-colon ()
+"Move point forward after the terminating colon
+of a target has been inserted.
+This accts according to the value of makefile-tab-after-target-colon ."
+  (if makefile-tab-after-target-colon
+      (insert "\t")
+    (insert " ")))
+
+(defun makefile-browser-on-macro-line-p ()
+  "Determine if point is on a macro line in the browser."
+  (save-excursion
+    (beginning-of-line)
+    (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t)))
+
+(defun makefile-browser-this-line-target-name ()
+  "Extract the target name from a line in the browser."
+  (save-excursion
+    (end-of-line)
+    (skip-chars-backward "^ \t")
+    (buffer-substring (point) (1- (makefile-end-of-line-point)))))
+
+(defun makefile-browser-this-line-macro-name ()
+  "Extract the macro name from a line in the browser."
+  (save-excursion
+    (beginning-of-line)
+    (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t)
+    (let ((macro-start (point)))
+      (skip-chars-forward "^})")
+      (buffer-substring macro-start (point)))))
+
+(defun makefile-format-macro-ref (macro-name)
+  "Format a macro reference according to the value of the
+configuration variable makefile-use-curly-braces-for-macros-p ."
+  (if makefile-use-curly-braces-for-macros-p
+      (format "${%s}" macro-name)
+    (format "$(%s)" macro-name)))
+
+(defun makefile-browser-get-state-for-line (n)
+  (aref makefile-browser-selection-vector (1- n)))
+
+(defun makefile-browser-set-state-for-line (n to-state)
+  (aset makefile-browser-selection-vector (1- n) to-state))
+
+(defun makefile-browser-toggle-state-for-line (n)
+  (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n))))
+
+(defun makefile-beginning-of-line-point ()
+  (save-excursion
+    (beginning-of-line)
+    (point)))
+
+(defun makefile-end-of-line-point ()
+  (save-excursion
+    (end-of-line)
+    (point)))
+
+(defun makefile-last-line-p ()
+  (= (makefile-end-of-line-point) (point-max)))
+
+(defun makefile-first-line-p ()
+  (= (makefile-beginning-of-line-point) (point-min)))
+
+;; makefile.el ends here
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
new file mode 100644
index 00000000000..61437f14bb9
--- /dev/null
+++ b/lisp/textmodes/sgml-mode.el
@@ -0,0 +1,266 @@
+;;; sgml-mode.el --- SGML-editing mode
+
+;; Maintainer: FSF
+;; Last-Modified: 14 Jul 1992
+;; Adapted-By: ESR
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; Some suggestions for your .emacs file:
+;;
+;; (autoload 'sgml-mode "sgml-mode" "SGML mode" t)
+;;
+;; (setq auto-mode-alist 
+;;       (append (list (cons "\\.sgm$" 'sgml-mode)
+;;                     (cons "\\.sgml$"  'sgml-mode)
+;;                     (cons "\\.dtd$" 'sgml-mode))
+;;               auto-mode-alist))
+
+;;; Code:
+
+(provide 'sgml-mode)
+(require 'compile)
+
+;;; sgmls is a free SGML parser available from
+;;; ftp.uu.net:pub/text-processing/sgml
+;;; Its error messages can be parsed by next-error.
+;;; The -s option suppresses output.
+
+(defconst sgml-validate-command
+  "sgmls -s"
+  "*The command to validate an SGML document.
+The file name of current buffer file name will be appended to this,
+separated by a space.")
+
+(defvar sgml-saved-validate-command nil
+  "The command last used to validate in this buffer.")
+
+(defvar sgml-mode-map nil "Keymap for SGML mode")
+
+(if sgml-mode-map
+    ()
+  (setq sgml-mode-map (make-sparse-keymap))
+  (define-key sgml-mode-map ">" 'sgml-close-angle)
+  (define-key sgml-mode-map "/" 'sgml-slash)
+  (define-key sgml-mode-map "\C-c\C-v" 'sgml-validate))
+
+(defun sgml-mode ()
+  "Major mode for editing SGML.
+Makes > display the matching <.  Makes / display matching /.
+Use \\[sgml-validate] to validate your document with an SGML parser."
+  (interactive)
+  (kill-all-local-variables)
+  (setq local-abbrev-table text-mode-abbrev-table)
+  (use-local-map sgml-mode-map)
+  (setq mode-name "SGML")
+  (setq major-mode 'sgml-mode)
+  (make-local-variable 'paragraph-start)
+  ;; A start or end tag by itself on a line separates a paragraph.
+  ;; This is desirable because SGML discards a newline that appears
+  ;; immediately after a start tag or immediately before an end tag.
+  (setq paragraph-start
+        "^[ \t\n]\\|\
+\\(</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$\\)")
+  (make-local-variable 'paragraph-separate)
+  (setq paragraph-separate
+        "^[ \t\n]*$\\|\
+^</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$")
+  (make-local-variable 'sgml-saved-validate-command)
+  (set-syntax-table text-mode-syntax-table)
+  (make-local-variable 'comment-start)
+  (setq comment-start "<!-- ")
+  (make-local-variable 'comment-end)
+  (setq comment-end " -->")
+  (make-local-variable 'comment-indent-hook)
+  (setq comment-indent-hook 'sgml-comment-indent)
+  (make-local-variable 'comment-start-skip)
+  ;; This will allow existing comments within declarations to be
+  ;; recognized.
+  (setq comment-start-skip "--[ \t]*")
+  (run-hooks 'text-mode-hook 'sgml-mode-hook))
+
+(defun sgml-comment-indent ()
+  (if (and (looking-at "--")
+           (not (and (eq (char-after (1- (point))) ?!)
+                     (eq (char-after (- (point) 2)) ?<))))
+      (progn
+        (skip-chars-backward " \t")
+        (max comment-column (1+ (current-column))))
+    0))
+
+(defconst sgml-start-tag-regex
+  "<[A-Za-z]\\([-.A-Za-z0-9= \n\t]\\|\"[^\"]*\"\\|'[^']*'\\)*"
+  "Regular expression that matches a non-empty start tag.
+Any terminating > or / is not matched.")
+
+(defvar sgml-mode-markup-syntax-table nil
+  "Syntax table used for scanning SGML markup.")
+
+(if sgml-mode-markup-syntax-table
+    ()
+  (setq sgml-mode-markup-syntax-table (make-syntax-table))
+  (modify-syntax-entry ?< "(>" sgml-mode-markup-syntax-table)
+  (modify-syntax-entry ?> ")<" sgml-mode-markup-syntax-table)
+  (modify-syntax-entry ?- "_ 1234" sgml-mode-markup-syntax-table)
+  (modify-syntax-entry ?\' "\"" sgml-mode-markup-syntax-table))
+
+(defconst sgml-angle-distance 4000
+  "*If non-nil, is the maximum distance to search for matching <
+when > is inserted.")
+
+(defun sgml-close-angle (arg)
+  "Insert > and display matching <."
+  (interactive "p")
+  (insert-char ?> arg)
+  (if (> arg 0)
+      (let ((oldpos (point))
+            (blinkpos))
+        (save-excursion
+          (save-restriction
+            (if sgml-angle-distance
+                (narrow-to-region (max (point-min)
+                                       (- (point) sgml-angle-distance))
+                                  oldpos))
+            ;; See if it's the end of a marked section.
+            (and (> (- (point) (point-min)) 3)
+                 (eq (char-after (- (point) 2)) ?\])
+                 (eq (char-after (- (point) 3)) ?\])
+                 (re-search-backward "<!\\[\\(-?[A-Za-z0-9. \t\n&;]\\|\
+--\\([^-]\\|-[^-]\\)*--\\)*\\["
+                                     (point-min)
+                                     t)
+                 (let ((msspos (point)))
+                   (if (and (search-forward "]]>" oldpos t)
+                            (eq (point) oldpos))
+                       (setq blinkpos msspos))))
+            ;; This handles cases where the > ends one of the following:
+            ;; markup declaration starting with <! (possibly including a
+            ;; declaration subset); start tag; end tag; SGML declaration.
+            (if blinkpos
+                ()
+              (goto-char oldpos)
+              (condition-case ()
+                  (let ((oldtable (syntax-table))
+                        (parse-sexp-ignore-comments t))
+                    (unwind-protect
+                        (progn
+                          (set-syntax-table sgml-mode-markup-syntax-table)
+                          (setq blinkpos (scan-sexps oldpos -1)))
+                      (set-syntax-table oldtable)))
+                (error nil))
+              (and blinkpos
+                   (goto-char blinkpos)
+                   (or
+                    ;; Check that it's a valid delimiter in context.
+                    (not (looking-at
+                          "<\\(\\?\\|/?[A-Za-z>]\\|!\\([[A-Za-z]\\|--\\)\\)"))
+                    ;; Check that it's not a net-enabling start tag
+                    ;; nor an unclosed start-tag.
+                    (looking-at (concat sgml-start-tag-regex "[/<]"))
+                    ;; Nor an unclosed end-tag.
+                    (looking-at "</[A-Za-z][-.A-Za-z0-9]*[ \t]*<"))
+                   (setq blinkpos nil)))
+            (if blinkpos
+                ()
+              ;; See if it's the end of a processing instruction.
+              (goto-char oldpos)
+              (if (search-backward "<?" (point-min) t)
+                  (let ((pipos (point)))
+                    (if (and (search-forward ">" oldpos t)
+                             (eq (point) oldpos))
+                        (setq blinkpos pipos))))))
+          (if blinkpos
+              (progn
+                (goto-char blinkpos)
+                (if (pos-visible-in-window-p)
+                    (sit-for 1)
+                  (message "Matches %s"
+                           (buffer-substring blinkpos
+                                             (progn (end-of-line)
+                                                    (point)))))))))))
+
+;;; I doubt that null end tags are used much for large elements,
+;;; so use a small distance here.
+(defconst sgml-slash-distance 1000
+  "*If non-nil, is the maximum distance to search for matching /
+when / is inserted.")
+
+(defun sgml-slash (arg)
+  "Insert / and display any previous matching /.
+Two /s are treated as matching if the first / ends a net-enabling
+start tag, and the second / is the corresponding null end tag."
+  (interactive "p")
+  (insert-char ?/ arg)
+  (if (> arg 0)
+      (let ((oldpos (point))
+            (blinkpos)
+            (level 0))
+        (save-excursion
+          (save-restriction
+            (if sgml-slash-distance
+                (narrow-to-region (max (point-min)
+                                       (- (point) sgml-slash-distance))
+                                  oldpos))
+            (if (and (re-search-backward sgml-start-tag-regex (point-min) t)
+                     (eq (match-end 0) (1- oldpos)))
+                ()
+              (goto-char (1- oldpos))
+              (while (and (not blinkpos)
+                          (search-backward "/" (point-min) t))
+                (let ((tagend (save-excursion
+                                (if (re-search-backward sgml-start-tag-regex
+                                                        (point-min) t)
+                                    (match-end 0)
+                                  nil))))
+                  (if (eq tagend (point))
+                      (if (eq level 0)
+                          (setq blinkpos (point))
+                        (setq level (1- level)))
+                    (setq level (1+ level)))))))
+          (if blinkpos
+              (progn
+                (goto-char blinkpos)
+                (if (pos-visible-in-window-p)
+                    (sit-for 1)
+                  (message "Matches %s"
+                           (buffer-substring (progn
+                                               (beginning-of-line)
+                                               (point))
+                                             (1+ blinkpos))))))))))
+
+(defun sgml-validate (command)
+  "Validate an SGML document.
+Runs COMMAND, a shell command, in a separate process asynchronously
+with output going to the buffer *compilation*.
+You can then use the command \\[next-error] to find the next error message
+and move to the line in the SGML document that caused it."
+  (interactive
+   (list (read-string "Validate command: "
+                      (or sgml-saved-validate-command
+                          (concat sgml-validate-command
+                                  " "
+                                  (let ((name (buffer-file-name)))
+                                    (and name
+                                         (file-name-nondirectory name))))))))
+  (setq sgml-saved-validate-command command)
+  (compile1 command "No more errors"))
+
+;;; sgml-mode.el ends here
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
new file mode 100644
index 00000000000..a2ccdd3fd60
--- /dev/null
+++ b/lisp/textmodes/two-column.el
@@ -0,0 +1,646 @@
+;;; two-column.el --- minor mode for editing of two-column text
+
+;; Author: Daniel Pfeiffer <pfeiffer@cix.cict.fr>
+;; Last-Modified: 14 May 1991
+;; Adapted-By: ESR
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; --8<---- two-column.el ----8<--------8<--------8<--------8<--------8<-------
+;; Esperanto:                           English:
+
+;; Minora modalo por samtempa dukolumna Minor mode for simultaneous
+;; tajpado                              two-column editing
+
+;; ^Ci dataro estas ero de GNU Emacs.   This file is part of GNU Emacs.
+
+;; GNU  Emacs  estas  disdonata   en la GNU Emacs is distributed in the hope
+;; espero  ke ^gi estos utila,  sed SEN that it will  be useful, but WITHOUT
+;; IA  GARANTIO.   Neniu   a^utoro  a^u ANY    WARRANTY.     No  author   or
+;; disdonanto  akceptas respondecon  al distributor   accepts responsibility
+;; iu ajn  por la sekvoj de ^gia uzado, to  anyone for the   consequences of
+;; a^u  ^cu  ^gi serveblas al  iu celo, using it or  for  whether it  serves
+;; a^u e^c  entute funkcias,  se  li ni any particular purpose   or works at
+;; estas skribinta  tion.  Vidu la  GNU all,  unless he says so  in writing.
+;; Emacs ^Generala Publika  Licenco por Refer  to  the   GNU  Emacs  General
+;; plenaj detaloj.                      Public License for full details.
+
+;; ^Ciu rajtas  kopii,  modifi kaj  ree Everyone  is  granted permission  to
+;; disdoni  GNU Emacs,  sed nur  sub la copy,  modify and  redistribute  GNU
+;; condi^coj  priskribitaj  en  la  GNU Emacs, but only under the conditions
+;; Emacs  ^Generala  Publika   Licenco. described in  the  GNU Emacs General
+;; Kopio de  tiu licenso estas supozata Public  License.   A copy   of  this
+;; donita al vi kune kun GNU Emacs, por license  is supposed to have    been
+;; ke   vi  sciu   viajn  rajtojn   kaj given to you along with GNU Emacs so
+;; respondecojn.   ^Gi  devus  esti  en you   can   know   your   rights and
+;; dataro    nomata    COPYING.   Inter responsibilities.  It should be in a
+;; alia^joj,  la notico  pri  kopirajto file named    COPYING.   Among other
+;; kaj  ^ci  notico devas esti  gardata things, the  copyright   notice  and
+;; sur ^ciuj kopioj.                    this notice must be preserved on all
+;;                                      copies.
+
+
+;; Tiu minora  modalo  ebligas  al   vi This     minor mode  allows  you  to
+;; tajpi   sendepende  en   du   apudaj independently    edit two   adjacent
+;; bufroj.  Vi  havas tri eblecojn  por buffers.    You have three  ways  to
+;; eki    ^gin.   ^Ciu  donas  al    vi start it  up.   Each  gives   you  a
+;; horizontale   disigatan   fenestron, horizontally split window similar to
+;; simila  al  fina   apareco  de   via the final outcome of your text:
+;; teksto:
+
+;; C-x 6 2  asocias  novan  bufron  nomatan  associates a new  buffer called
+;;         same, sed kun 2C/ anta^u.        the   same,    but   with   2C/
+;;                                          prepended.
+
+;; C-x 6 b  asocias alian bufron.  Vi povas  associates    another   buffer.
+;;         anka^u asocii  dataron,   se vi  This can be used to associate a
+;;         ^jus anta^ue faris C-x C-f.      file if you just did C-x C-f.
+
+;; C-x 6 u  disigas  jam dukolumnan tekston  unmerges a two-column text into
+;;         en  du   bufroj  ekde  la  nuna  two  buffers from  the  current
+;;         linio,  kaj je la nuna kolumno.  line and at the current column.
+;;         La    anta^uaj   signoj   (ofte  The preceding characters (often
+;;         tabeligilo  a^u  |)  estas   la  tab   or  |)  are   the  column
+;;         kolumna disiganto.  Linioj kiuj  separator.   Lines  that  don't
+;;         ne   enhavas   ilin   ne  estas  have them  won't  be separated.
+;;         disigitaj.   Kiel  la kvara kaj  Like the  fourth and fifth line
+;;         la   kvina  linio se vi disigas  if  you unmerge this  file from
+;;         ^ci dataron ekde la unua  angla  the first english word.
+;;         vorto.
+
+;; Je ^cia  flanko  estas  bufro,   kiu On each side is a buffer  that knows
+;; konas la  alian.  Kun la ordonoj C-x about the other.  With the  commands
+;; 6 SPC, C-x 6 DEL  kaj  C-x 6 RET oni C-x 6 SPC,  C-x 6 DEL  and C-x 6 RET
+;; povas   suben-   a^u  supreniri  unu you can  simultaneously scroll up or
+;; ekranon,    kaj   subeniri   linion, down by  a screenfull  and by a line
+;; samtempe en la du bufroj. Al la alia in both buffers.   Empty lines   are
+;; bufro  estas   aldonataj  linioj  se added to  the  other    buffer    if
+;; necesas,  por  ke  vi vidu la  saman necessary, so that  you see the same
+;; parton.  Per  C-x  6  C-l vi   povas part.   With   C-x 6  C-l    you can
+;; recentrigi la linion.    Kiam vi nur recenter the line.   When  you  only
+;; plu  havas    unu el   la du  bufroj have one of the two buffers onscreen
+;; surekrane vi  revidos la alian   per you can get the other back  with C-x
+;; denove C-x 6 2.                      6 2 once more.
+
+;; Se  vi  volas  meti  longajn liniojn If you include long lines, i.e which
+;; (ekz. programerojn) en la  kunigotan will span both columns  (eg.  source
+;; tekston,   ili  devas  esti  en   la code), they should  be  in what will
+;; estonte unua kolumno.  La alia devas be the    first column,    with  the
+;; havi malplenajn linion apud ili.     associated buffer having empty lines
+;;                                      next to them.
+
+;; Averto: en Emacs kiam vi ^san^gas la Attention:  in Emacs when you change
+;; ma^joran modalon, la minoraj modaloj the major mode,  the minor modes are
+;; estas  anka^u  elmemorigitaj.   Tiu- also  purged  from  memory.  In that
+;; okaze  vi devas religi la du bufrojn case you   must  reassociate the two
+;; per iu  C-x 6-ordono,  ekz. C-x 6 b. buffers with any C-x 6-command, e.g.
+;;                                      C-x 6 b.
+
+;; Kiam   vi   estos  kontenta   de  la When you have edited both buffers to
+;; rezulto, vi kunmetos la du kolumnojn your  content,  you merge them  with
+;; per  C-x 6 1.   Se  vi  poste  vidas C-x 6 1.  If you then see a problem,
+;; problemon, vi  neniigu   la kunmeton you undo the  merge with  C-x u  and
+;; per C-x u  kaj  plue  modifu  la  du continue   to  edit the two buffers.
+;; bufrojn.  Kiam vi ne plu volas tajpi When you  no longer  want to edit in
+;; dukolumne,  vi  eliru el  la  minora two  columns, you turn off the minor
+;; modalo per C-x 6 k.                  mode with C-x 6 k.
+
+
+;; An^stata^u tri `autoload' kaj tri  |  Instead  of  three  `autoload' and
+;; `global-set-key'  vi povas uzi la  |  three `global-set-key' you can use
+;; jenon en via dataro ~/.emacs, por  |  the    following   in  your   file
+;; memstare ^car^gi la modalon:      |  ~/.emacs,  to  automatically  load
+;;                                   |  the mode:
+
+;;      (global-set-key "\C-x6"
+;;                      '(lambda () (interactive)
+;;                         (load-library "two-column")
+;;                         (call-interactively
+;;                          (cdr (assq (read-char) tc-mode-map)))))
+
+;; Se vi ^satus  havi la dukolumnajn  |  If     you'd like   to  have   the
+;; ordonojn je funkciklavo <f2>,  vi  |  two-column  commands   on function
+;; povas  uzi la jenon en via dataro  |  key   <f2>,  you  can     use  the
+;; ~/.emacs:                         |  following in your file ~/.emacs:
+
+;;      (define-key function-keymap "\^b"
+;;        '(lambda () (interactive)
+;;           (load-library "two-column")
+;;           (define-key function-keymap "\^b" tc-mode-map)
+;;           (call-interactively
+;;            (cdr (assq (read-char) tc-mode-map)))))
+
+;; In addition to two-column editing of text, for example for writing a
+;; bilingual text side-by-side as shown below in the file's prolog, other
+;; interesting uses have been found for this minor mode:
+;; 
+;; 
+;; You can separate the columns with    {+} C-x 6 u  or  <f2> u  if you prefer
+;; any string that pleases you, by      {+} handles these with a prefix argument
+;; setting tc-separator.  For   {+} that enables you to declare the
+;; example "{+}  " if you like to       {+}  desired length of such a string.
+;; amuse yourself.
+;; 
+;; 
+;; keyword You can write any text corresponding to a
+;;        given keyword in a filled paragraph next to
+;;        it.  Note that the width of the first column
+;;        may be less than window-min-width in the
+;;        result, but will be displayed at that width.
+;; 
+;; another This is not a three- or multi-column mode.
+;;        The example in the file's prolog required
+;;        working on two columns and then treating the
+;;        result as one column in order to add the
+;;        third.
+;; 
+;; 
+;; Programmers might like the ability to split off the comment column of
+;; a file that looks like the following.  The advantage is that with
+;; (setq fill-prefix "-- ") you can run M-q (fill-paragraph) on the
+;; comment.  The problem is, code quickly gets rather wide, so you need
+;; to use a narrower comment column, which is less interesting, unless
+;; you have a 132-column screen.  Code lines that reach beyond
+;; comment-column are no problem, except that you won't always see their
+;; end during editing.
+;; 
+;; BEGIN                                -- This is just some meaningless
+;;     FOR i IN 1..10 LOOP              -- code in Ada, that runs foobar
+;;      foobar( i );                    -- once for each argument from one
+;;     END LOOP;                        -- to ten, and then we're already
+;; END;                                 -- through with it.
+;; 
+;; Better yet, you can put the point before "This", type M-3 C-x 6 u
+;; which makes "-- " the separator between a no-comments Ada buffer, and
+;; a plain text comment buffer.  When you put them back together, every
+;; non-empty line of the 2nd column will again be preceded by "-- ".
+;; 
+;; 
+;; The <f2> function key hack (which is one of the rare times when
+;; function keys are mnemonic) at the end of the file's prolog requires
+;; that the lisp/term/*.el for your terminal use the standard
+;; conventions.  Too bad that some don't (at least not in version 18.55).
+;; The Sun one is hopelessly non-standard, and vt2[024]0 somehow forgot
+;; to define <f1> thru <f5>.  (It defines <pf1> thru <pf4> instead, but
+;; that is not what we need on an X terminal.)  If you want to use those,
+;; you'll need another hack something like:
+;; 
+;;       (if (string= (system-name) "cix")
+;;        (progn
+;;          (load-library "term/vt200.el")
+;;          (define-key CSI-map "12~" (cons function-keymap ?\^b)))
+;;      (global-unset-key "\e[")
+;;      (define-key esc-map "[225z" (cons function-keymap ?\^b)))
+;; 
+;; where "cix" is the non-sun machine I use.  Actually I use the same X
+;; terminal to connect to both machines, and I want to keep my ~/.emacs
+;; identical on both.  Bother, the two Emacses don't recognize the same
+;; keys and assign different sequences to those they do!  I sure hope all
+;; this nonsense will stop with version 19 (or preferably soon) where I'd
+;; like to be able to say (define-key some-map '<f2> some-cmd), and see
+;; <f2> rather than some unintelligible ESC-sequence in command key
+;; sequences.
+
+;;; Code:
+
+;;;;; variable declarations ;;;;;
+
+(provide 'two-column)
+
+(defvar tc-prefix "\C-x6"
+  "Prefix tc-mode-map gets bound to.
+If you'd like to bind it to function key <f2>, see the prolog of the
+source file, lisp/two-column.el")
+
+(defvar tc-mode-map nil
+  "Keymap that contains all commands useful with two-column minor mode.
+This gets bound globally to `tc-prefix' since minor modes have
+no local keymap.")
+
+(if tc-mode-map
+    ()
+  (setq tc-mode-map (make-sparse-keymap))
+  (define-key tc-mode-map "1" 'tc-merge)
+  (define-key tc-mode-map "2" 'tc-split)
+  (define-key tc-mode-map "b" 'tc-associate-buffer)
+  (define-key tc-mode-map "k" 'tc-kill-association)
+  (define-key tc-mode-map "\C-l" 'tc-recenter)
+  (define-key tc-mode-map "o" 'tc-associated-buffer)
+  (define-key tc-mode-map "u" 'tc-unmerge)
+  (define-key tc-mode-map "{" 'shrink-window-horizontally)
+  (define-key tc-mode-map "}" 'enlarge-window-horizontally)
+  (define-key tc-mode-map " " 'tc-scroll-up)
+  (define-key tc-mode-map "\^?" 'tc-scroll-down)
+  (define-key tc-mode-map "\C-m" 'tc-scroll-line))
+
+(global-set-key tc-prefix tc-mode-map)
+
+
+;; markers seem to be the only buffer-id not affected by renaming
+;; a buffer.  This nevertheless loses when a buffer is killed.
+(defvar tc-other nil
+  "Marker to the associated buffer, if non-nil.")
+(make-variable-buffer-local 'tc-other)
+
+
+(defvar tc-buffer-list ()
+  "An alist of markers to associated buffers.  (Backs up `tc-other')")
+
+(setq minor-mode-alist (cons '(tc-other " 2C") minor-mode-alist))
+
+;; rearranged, so that the pertinent info will show in 40 columns
+(defvar tc-mode-line-format
+        '("-%*- %15b --"  (-3 . "%p")  "--%[("  mode-name
+          minor-mode-alist  "%n"  mode-line-process  ")%]%-")
+  "*Value of mode-line-format for a buffer in two-column minor mode.")
+
+(defvar tc-separator ""
+  "*A string inserted between the two columns when merging.
+This gets set locally by \\[tc-unmerge].")
+
+(defvar tc-window-width 40
+  "*The width of the first column.  (Must be at least `window-min-width')
+This value is local for every buffer that sets it.")
+(make-variable-buffer-local 'tc-window-width)
+
+(defvar tc-beyond-fill-column 4
+  "*Base for calculating `fill-column' for a buffer in two-column minor mode.
+The value of `fill-column' becomes `tc-window-width' for this buffer
+minus this value.")
+
+(defvar tc-mode-hook nil
+  "Function called, if non-nil, whenever turning on two-column minor mode.
+It can get called by \\[tc-split] (tc-split), \\[tc-unmerge] (tc-unmerge)
+and \\[tc-associate-buffer] (tc-associate-buffer), on both buffers.")
+
+;;;;; base functions ;;;;;
+
+;; the access method for the other buffer.  this tries to remedy against
+;; lost local variables and lost buffers.
+(defun tc-other ()
+  (if (or tc-other
+          (setq tc-other
+                ; assoc with a different predicate, since we don't know
+                ; which marker points to this buffer
+                (let ((bl tc-buffer-list))
+                  (while (and bl (not (eq (current-buffer)
+                                          (marker-buffer (car (car bl))))))
+                    (setq bl (cdr bl)))
+                  (cdr (car bl)))))
+      (or (prog1
+              (marker-buffer tc-other)
+            (setq mode-line-format tc-mode-line-format ))
+          ; The associated buffer somehow got killed.
+          (progn
+            ; The other variables may later be useful if the user
+            ; reestablishes the association.
+            (kill-local-variable 'tc-other)
+            (kill-local-variable 'mode-line-format)
+            nil))))
+
+(defun tc-split (&optional buffer)
+  "Split current window vertically for two-column editing.
+
+When called the first time, associates a buffer with the current
+buffer.  Both buffers are put in two-column minor mode and
+tc-mode-hook gets called on both.  These buffers remember
+about one another, even when renamed.
+
+When called again, restores the screen layout with the current buffer
+first and the associated buffer to it's right.
+
+If you include long lines, i.e which will span both columns (eg.
+source code), they should be in what will be the first column, with
+the associated buffer having empty lines next to them.
+
+You have the following commands at your disposal:
+
+\\[tc-split]   Rearrange screen
+\\[tc-associate-buffer]   Reassociate buffer after changing major mode
+\\[tc-scroll-up]   Scroll both buffers up by a screenfull
+\\[tc-scroll-down]   Scroll both buffers down by a screenful
+\\[tc-scroll-line]   Scroll both buffers up by one or more lines
+\\[tc-recenter]   Recenter and realign other buffer
+\\[shrink-window-horizontally], \\[enlarge-window-horizontally]   Shrink, enlarge current column
+\\[tc-associated-buffer]   Switch to associated buffer
+\\[tc-merge]   Merge both buffers
+
+These keybindings can be customized in your ~/.emacs by `tc-prefix'
+and `tc-mode-map'.
+
+The appearance of the screen can be customized by the variables
+`tc-window-width', `tc-beyond-fill-column',
+`tc-mode-line-format' and `truncate-partial-width-windows'."
+
+  (interactive "P")
+  ; first go to full width, so that we can certainly split into
+  ; two windows
+  (if (< (window-width) (screen-width))
+      (enlarge-window 99999 t))
+  (split-window-horizontally
+   (max window-min-width (min tc-window-width
+                              (- (screen-width) window-min-width))))
+  (if (tc-other)
+      (progn
+        (other-window 1)
+        (switch-to-buffer (tc-other))
+        (other-window -1)
+        ; align buffers if necessary
+        (tc-scroll-line 0))
+
+    ; set up minor mode linking two buffers
+    (setq fill-column (- tc-window-width
+                         tc-beyond-fill-column)
+          mode-line-format tc-mode-line-format)
+    (run-hooks tc-mode-hook)
+    (let ((other (point-marker)))
+      (other-window 1)
+      (switch-to-buffer
+       (or buffer
+           (generate-new-buffer
+            (concat "2C/" (buffer-name)))))
+      (or buffer
+          (text-mode))
+      (setq fill-column (- tc-window-width
+                           tc-beyond-fill-column)
+            mode-line-format tc-mode-line-format
+            tc-other other
+            other (point-marker))
+      (setq tc-buffer-list (cons (cons tc-other other)
+                                         tc-buffer-list))
+      (run-hooks tc-mode-hook)
+      (other-window -1)
+      (setq tc-buffer-list
+            (cons (cons other
+                        (save-excursion
+                          (set-buffer (tc-other))
+                          tc-other))
+                  tc-buffer-list))
+      (setq tc-other other))))
+
+(fset 'tc-mode 'tc-split)
+
+(defun tc-associate-buffer ()
+  "Associate another buffer with this one in two-column minor mode.
+Can also be used to associate a just previously visited file, by
+accepting the proposed default buffer.
+
+See  \\[tc-split]  and  `lisp/two-column.el'  for further details."
+  (interactive)
+  (let ((b1 (current-buffer))
+        (b2 (or (tc-other)
+                (read-buffer "Associate buffer: " (other-buffer)))))
+    (save-excursion
+      (setq tc-other nil)
+      (set-buffer b2)
+      (and (tc-other)
+           (not (eq b1 (tc-other)))
+           (error "Buffer already associated with buffer `%s'."
+                  (buffer-name (tc-other))))
+      (setq b1 (and (assq 'tc-window-width (buffer-local-variables))
+                    tc-window-width)))
+    ; if other buffer has a local width, adjust here too
+    (if b1 (setq tc-window-width (- (screen-width) b1)))
+    (tc-split b2)))
+
+(defun tc-unmerge (arg)
+  "Unmerge a two-column text into two buffers in two-column minor mode.
+The text is unmerged at the cursor's column which becomes the local
+value of tc-window-width.  Only lines that have the ARG same
+preceding characters at that column get split.  The ARG preceding
+characters without any leading whitespace become the local value for
+`tc-separator'.  This way lines that continue across both
+columns remain untouched in the first buffer.
+
+This function can be used with a prototype line, to set up things as
+you like them.  You write the first line of each column with the
+separator you like and then unmerge that line.  E.g.:
+
+First column's text    sSs  Second columns text
+                       \\___/\\
+                        /    \\
+   5 character Separator      You type  M-5 \\[tc-unmerge]  with the point here
+
+See  \\[tc-split]  and  `lisp/two-column.el'  for further details."
+  (interactive "p")
+  (and (tc-other)
+       (if (y-or-n-p (concat "Overwrite associated buffer `"
+                             (buffer-name (tc-other))
+                             "'? "))
+           (save-excursion
+             (set-buffer (tc-other))
+             (erase-buffer))
+         (signal 'quit nil)))
+  (let ((point (point))
+        ; make next-line always come back to same column
+        (goal-column (current-column))
+        ; a counter for empty lines in other buffer
+        (n (1- (count-lines (point-min) (point))))
+        chars other)
+    (save-excursion
+      (backward-char arg)
+      (setq chars (buffer-substring (point) point))
+      (skip-chars-forward " \t" point)
+      (make-variable-buffer-local 'tc-separator)
+      (setq tc-separator (buffer-substring (point) point)
+            tc-window-width (current-column)))
+    (tc-split)
+    (setq other (tc-other))
+    ; now we're ready to actually unmerge
+    (save-excursion
+      (while (not (eobp))
+        (if (not (and (= (current-column) goal-column)
+                      (string= chars
+                               (buffer-substring (point)
+                                                 (save-excursion
+                                                   (backward-char arg)
+                                                   (point))))))
+            (setq n (1+ n))
+          (setq point (point))
+          (backward-char arg)
+          (skip-chars-backward " \t")
+          (delete-region point (point))
+          (setq point (point))
+          (insert-char ?\n n)
+          (append-to-buffer other point (progn (end-of-line)
+                                               (if (eobp)
+                                                   (point)
+                                                 (1+ (point)))))
+          (delete-region point (point))
+          (setq n 0))
+        (next-line 1)))))
+
+(defun tc-kill-association ()
+  "Turn off two-column minor mode in current and associated buffer.
+If the associated buffer is unmodified and empty, it is killed."
+  (interactive)
+  (let ((buffer (current-buffer)))
+    (save-excursion
+      (and (tc-other)
+           (prog2
+            (setq tc-buffer-list
+                  (delq (assq tc-other tc-buffer-list)
+                        tc-buffer-list))
+            (set-buffer (tc-other))
+            (setq tc-buffer-list
+                  (delq (assq tc-other tc-buffer-list)
+                        tc-buffer-list)))
+           (or (not (tc-other))
+               (eq buffer (tc-other)))
+           (if (and (not (buffer-modified-p))
+                    (eobp) (bobp))
+               (kill-buffer nil)
+             (kill-local-variable 'tc-other)
+             (kill-local-variable 'tc-window-width)
+             (kill-local-variable 'tc-separator)
+             (kill-local-variable 'mode-line-format)
+             (kill-local-variable 'fill-column))))
+    (kill-local-variable 'tc-other)
+    (kill-local-variable 'tc-window-width)
+    (kill-local-variable 'tc-separator)
+    (kill-local-variable 'mode-line-format)
+    (kill-local-variable 'fill-column)))
+
+
+;; this doesn't use yank-rectangle, so that the first column can
+;; contain long lines
+(defun tc-merge ()
+  "Merges the associated buffer with the current buffer.
+They get merged at the column, which is the value of
+`tc-window-width', i.e. usually at the vertical window
+separator.  This separator gets replaced with white space.  Beyond
+that the value of gets inserted on merged lines.  The two columns are
+thus pasted side by side, in a single text.  If the other buffer is
+not displayed to the left of this one, then this one becomes the left
+column.
+
+If you want `tc-separator' on empty lines in the second column,
+you should put just one space in them.  In the final result, you can strip
+off trailing spaces with \\[beginning-of-buffer] \\[replace-regexp] [ SPC TAB ] + $ RET RET"
+
+  (interactive)
+  (or (tc-other)
+      (error "You must first set two-column minor mode."))
+  (and (> (car (window-edges)) 0)       ; not touching left edge of screen
+       (eq (window-buffer (previous-window))
+           (tc-other))
+       (other-window -1))
+  (save-excursion
+    (let ((b1 (current-buffer))
+          (b2 (tc-other))
+          string)
+      (goto-char (point-min))
+      (set-buffer b2)
+      (goto-char (point-min))
+      (while (not (eobp))
+        (setq string (buffer-substring (point)
+                                       (progn (end-of-line) (point))))
+        (or (eobp)
+            (forward-char))             ; next line
+        (set-buffer b1)
+        (if (string= string "")
+            ()
+          (end-of-line)
+          (indent-to-column tc-window-width)
+          (insert tc-separator string))
+        (next-line 1)                   ; add one if necessary
+        (set-buffer b2))))
+  (if (< (window-width) (screen-width))
+      (enlarge-window 99999 t)))
+
+;;;;; utility functions ;;;;;
+
+(defun tc-associated-buffer ()
+  "Switch to associated buffer."
+  (interactive)
+  (or (tc-other)
+      (error "You must set two-column minor mode."))
+  (if (get-buffer-window (tc-other))
+      (select-window (get-buffer-window (tc-other)))
+    (switch-to-buffer (tc-other))))
+
+;; It would be desirable to intercept anything that causes the current
+;; window to scroll.  Maybe a `scroll-hook'?
+(defun tc-scroll-line (arg)
+  "Scroll current window upward by ARG lines.
+The associated window gets scrolled to the same line."
+  (interactive "p")
+  (or (tc-other)
+      (error "You must set two-column minor mode."))
+  ; scroll-up has a bug on arg 0 at end of buffer
+  (or (zerop arg)
+      (scroll-up arg))
+  (setq arg (count-lines (point-min) (window-start)))
+  ; too bad that pre 18.57 Emacs makes save-window-excursion restore
+  ; the point.  When it becomes extinct, we can simplify this.
+  (if (get-buffer-window (tc-other))
+      (let ((window (selected-window)))
+        (select-window (get-buffer-window (tc-other)))
+        (setq arg (- arg (count-lines (point-min) (window-start))))
+        ; make sure that other buffer has enough lines
+        (save-excursion
+          (goto-char (point-max))
+          (insert-char ?\n
+                       (- arg (count-lines (window-start) (point-max)) -1)))
+        (or (zerop arg)
+            (scroll-up arg))
+        (select-window window))))
+
+(defun tc-scroll-up (arg)
+  "Scroll current window upward by ARG screens.
+The associated window gets scrolled to the same line."
+  (interactive "p")
+  (tc-scroll-line (* arg (- (window-height)
+                                    next-screen-context-lines 1))))
+
+(defun tc-scroll-down (arg)
+  "Scroll current window downward by ARG screens.
+The associated window gets scrolled to the same line."
+  (interactive "p")
+  (tc-scroll-line (* arg (- next-screen-context-lines
+                                    (window-height) -1))))
+
+(defun tc-recenter (arg)
+  "Center point in window.  With ARG, put point on line ARG.
+This counts from bottom if ARG is negative.  The associated window
+gets scrolled to the same line."
+  (interactive "P")
+  (setq arg (and arg (prefix-numeric-value arg)))
+  (tc-scroll-line (- (count-lines (window-start) (point))
+                             (cond ((null arg)  (/ (window-height) 2))
+                                   ((< arg 0)  (+ (window-height) arg))
+                                   (  arg)))))
+
+(defun enlarge-window-horizontally (arg)
+  "Make current window ARG columns wider."
+  (interactive "p")
+  (enlarge-window arg t)
+  (and (tc-other)
+       (setq tc-window-width (+ tc-window-width arg))
+       (set-buffer (tc-other))
+       (setq tc-window-width (- tc-window-width arg))))
+
+(defun shrink-window-horizontally (arg)
+  "Make current window ARG columns narrower."
+  (interactive "p")
+  (enlarge-window-horizontally (- arg)))
+
+;;; two-column.el ends here