--- /dev/null
+;; File input and output commands for Emacs
+;; Copyright (C) 1985, 1986, 1987, 1990 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.
+
+
+(defconst delete-auto-save-files t
+ "*Non-nil means delete a buffer's auto-save file
+when the buffer is saved for real.")
+
+;(make-variable-buffer-local 'buffer-backed-up)
+;(defvar buffer-backed-up nil
+; "Non-nil if this buffer's file has been backed up.
+;Backing up is done before the first time the file is saved.")
+
+;;; Turn off backup files on VMS since it has version numbers.
+(defconst make-backup-files (not (eq system-type 'vax-vms))
+ "*Create a backup of each file when it is saved for the first time.
+This can be done by renaming the file or by copying.
+
+Renaming means that Emacs renames the existing file so that it is a
+backup file, then writes the buffer into a new file. Any other names
+that the old file had will now refer to the backup file.
+The new file is owned by you and its group is defaulted.
+
+Copying means that Emacs copies the existing file into the backup file,
+then writes the buffer on top of the existing file. Any other names
+that the old file had will now refer to the new (edited) file.
+The file's owner and group are unchanged.
+
+The choice of renaming or copying is controlled by the variables
+backup-by-copying, backup-by-copying-when-linked and
+backup-by-copying-when-mismatch.")
+
+(defconst backup-by-copying nil
+ "*Non-nil means always use copying to create backup files.
+See documentation of variable make-backup-files.")
+
+(defconst backup-by-copying-when-linked nil
+ "*Non-nil means use copying to create backups for files with multiple names.
+This causes the alternate names to refer to the latest version as edited.
+This variable is relevant only if backup-by-copying is nil.")
+
+(defconst backup-by-copying-when-mismatch nil
+ "*Non-nil means create backups by copying if this preserves owner or group.
+Renaming may still be used (subject to control of other variables)
+when it would not result in changing the owner or group of the file;
+that is, for files which are owned by you and whose group matches
+the default for a new file created there by you.
+This variable is relevant only if backup-by-copying is nil.")
+
+(defconst buffer-offer-save nil
+ "*Non-nil in a buffer means offer to save the buffer on exit
+even if the buffer is not visiting a file. Automatically local in
+all buffers.")
+(make-variable-buffer-local 'buffer-offer-save)
+
+(defconst file-precious-flag nil
+ "*Non-nil means protect against I/O errors while saving files.
+Some modes set this non-nil in particular buffers.")
+
+(defvar version-control nil
+ "*Control use of version numbers for backup files.
+t means make numeric backup versions unconditionally.
+nil means make them for files that have some already.
+never means do not make them.")
+
+(defvar dired-kept-versions 2
+ "*When cleaning directory, number of versions to keep.")
+
+(defvar trim-versions-without-asking nil
+ "*If true, deletes excess backup versions silently.
+Otherwise asks confirmation.")
+
+(defvar kept-old-versions 2
+ "*Number of oldest versions to keep when a new numbered backup is made.")
+
+(defvar kept-new-versions 2
+ "*Number of newest versions to keep when a new numbered backup is made.
+Includes the new backup. Must be > 0")
+
+(defconst require-final-newline nil
+ "*t says silently put a newline at the end whenever a file is saved.
+Non-nil but not t says ask user whether to add a newline in each such case.
+nil means don't add newlines.")
+
+(defconst auto-save-default t
+ "*t says by default do auto-saving of every file-visiting buffer.")
+
+(defconst auto-save-visited-file-name nil
+ "*t says auto-save a buffer in the file it is visiting, when practical.
+Normally auto-save files are written under other names.")
+
+(defconst save-abbrevs nil
+ "*Non-nil means save word abbrevs too when files are saved.
+Loading an abbrev file sets this to t.")
+
+(defconst find-file-run-dired t
+ "*Non-nil says run dired if find-file is given the name of a directory.")
+
+(defvar find-file-not-found-hooks nil
+ "List of functions to be called for find-file on nonexistent file.
+These functions are called as soon as the error is detected.
+buffer-file-name is already set up.
+The functions are called in the order given,
+until one of them returns non-nil.")
+
+(defvar find-file-hooks nil
+ "List of functions to be called after a buffer is loaded from a file.
+The buffer's local variables (if any) will have been processed before the
+functions are called.")
+
+(defvar write-file-hooks nil
+ "List of functions to be called before writing out a buffer to a file.
+If one of them returns non-nil, the file is considered already written
+and the rest are not called.")
+
+(defconst inhibit-local-variables nil
+ "*Non-nil means query before obeying a file's local-variables list.
+This applies when the local-variables list is scanned automatically
+after you find a file. If you explicitly request such a scan with
+\\[normal-mode], there is no query, regardless of this variable.")
+
+;; Avoid losing in versions where CLASH_DETECTION is disabled.
+(or (fboundp 'lock-buffer)
+ (fset 'lock-buffer 'ignore))
+(or (fboundp 'unlock-buffer)
+ (fset 'unlock-buffer 'ignore))
+\f
+(defun pwd ()
+ "Show the current default directory."
+ (interactive nil)
+ (message "Directory %s" default-directory))
+
+(defun cd (dir)
+ "Make DIR become the current buffer's default directory."
+ (interactive "DChange default directory: ")
+ (setq dir (expand-file-name dir))
+ (if (not (eq system-type 'vax-vms))
+ (setq dir (file-name-as-directory dir)))
+ (if (not (file-directory-p dir))
+ (error "%s is not a directory" dir)
+ (setq default-directory dir))
+ (pwd))
+
+(defun load-file (file)
+ "Load the file FILE of Lisp code."
+ (interactive "fLoad file: ")
+ (load (expand-file-name file) nil nil t))
+
+(defun load-library (library)
+ "Load the library named LIBRARY.
+This is an interface to the function `load'."
+ (interactive "sLoad library: ")
+ (load library))
+\f
+(defun switch-to-buffer-other-window (buffer)
+ "Select buffer BUFFER in another window."
+ (interactive "BSwitch to buffer in other window: ")
+ (let ((pop-up-windows t))
+ (pop-to-buffer buffer t)))
+
+(defun find-file (filename)
+ "Edit file FILENAME.
+Switch to a buffer visiting file FILENAME,
+creating one if none already exists."
+ (interactive "FFind file: ")
+ (switch-to-buffer (find-file-noselect filename)))
+
+(defun find-file-other-window (filename)
+ "Edit file FILENAME, in another window.
+May create a new window, or reuse an existing one;
+see the function display-buffer."
+ (interactive "FFind file in other window: ")
+ (switch-to-buffer-other-window (find-file-noselect filename)))
+
+(defun find-file-read-only (filename)
+ "Edit file FILENAME but don't save without confirmation.
+Like find-file but marks buffer as read-only."
+ (interactive "fFind file read-only: ")
+ (find-file filename)
+ (setq buffer-read-only t))
+
+(defun find-alternate-file (filename)
+ "Find file FILENAME, select its buffer, kill previous buffer.
+If the current buffer now contains an empty file that you just visited
+\(presumably by mistake), use this command to visit the file you really want."
+ (interactive "FFind alternate file: ")
+ (and (buffer-modified-p)
+;;; (not buffer-read-only)
+ (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? "
+ (buffer-name))))
+ (error "Aborted"))
+ (let ((obuf (current-buffer))
+ (ofile buffer-file-name)
+ (oname (buffer-name)))
+ (rename-buffer " **lose**")
+ (setq buffer-file-name nil)
+ (unwind-protect
+ (progn
+ (unlock-buffer)
+ (find-file filename))
+ (cond ((eq obuf (current-buffer))
+ (setq buffer-file-name ofile)
+ (lock-buffer)
+ (rename-buffer oname))))
+ (kill-buffer obuf)))
+
+(defun create-file-buffer (filename)
+ "Create a suitably named buffer for visiting FILENAME, and return it.
+FILENAME (sans directory) is used unchanged if that name is free;
+otherwise a string <2> or <3> or ... is appended to get an unused name."
+ (let ((lastname (file-name-nondirectory filename)))
+ (if (string= lastname "")
+ (setq lastname filename))
+ (generate-new-buffer lastname)))
+
+(defun find-file-noselect (filename &optional nowarn)
+ "Read file FILENAME into a buffer and return the buffer.
+If a buffer exists visiting FILENAME, return that one,
+but verify that the file has not changed since visited or saved.
+The buffer is not selected, just returned to the caller."
+ (setq filename (expand-file-name filename))
+ ;; Get rid of the prefixes added by the automounter.
+ (if (string-match "^/tmp_mnt/" filename)
+ (setq filename (substring filename (1- (match-end 0)))))
+ (if (file-directory-p filename)
+ (if find-file-run-dired
+ (dired-noselect filename)
+ (error "%s is a directory." filename))
+ (let ((buf (get-file-buffer filename))
+ error)
+ (if buf
+ (or nowarn
+ (verify-visited-file-modtime buf)
+ (cond ((not (file-exists-p filename))
+ (error "File %s no longer exists!" filename))
+ ((yes-or-no-p
+ (if (buffer-modified-p buf)
+ "File has changed since last visited or saved. Flush your changes? "
+ "File has changed since last visited or saved. Read from disk? "))
+ (save-excursion
+ (set-buffer buf)
+ (revert-buffer t t)))))
+ (save-excursion
+ (setq buf (create-file-buffer filename))
+ (set-buffer buf)
+ (erase-buffer)
+ (condition-case ()
+ (insert-file-contents filename t)
+ (file-error
+ (setq error t)
+ ;; Run find-file-not-found-hooks until one returns non-nil.
+ (let ((hooks find-file-not-found-hooks))
+ (while (and hooks
+ (not (funcall (car hooks))))
+ (setq hooks (cdr hooks))))))
+ (setq default-directory (file-name-directory filename))
+ (after-find-file error (not nowarn))))
+ buf)))
+\f
+(defun after-find-file (&optional error warn)
+ "Called after finding a file and by the default revert function.
+Sets buffer mode, parses local variables.
+Optional args ERROR and WARN: ERROR non-nil means there was an
+error in reading the file. WARN non-nil means warn if there
+exists an auto-save file more recent than the visited file.
+Finishes by calling the functions in find-file-hooks."
+ (setq buffer-read-only (not (file-writable-p buffer-file-name)))
+ (if noninteractive
+ nil
+ (let* (not-serious
+ (msg
+ (cond ((not buffer-read-only)
+ (if (and warn
+ (file-newer-than-file-p (make-auto-save-file-name)
+ buffer-file-name))
+ "Auto save file is newer; consider M-x recover-file"
+ (setq not-serious t)
+ (if error "(New file)" nil)))
+ ((not error)
+ (setq not-serious t)
+ "File is write protected")
+ ((file-attributes buffer-file-name)
+ "File exists, but is read-protected.")
+ ((file-attributes (directory-file-name default-directory))
+ "File not found and directory write-protected")
+ (t
+ "File not found and directory doesn't exist"))))
+ (if msg
+ (progn
+ (message msg)
+ (or not-serious (sit-for 1 t)))))
+ (if auto-save-default
+ (auto-save-mode t)))
+ (normal-mode t)
+ (mapcar 'funcall find-file-hooks))
+
+(defun normal-mode (&optional find-file)
+ "Choose the major mode for this buffer automatically.
+Also sets up any specified local variables of the file.
+Uses the visited file name, the -*- line, and the local variables spec.
+
+This function is called automatically from `find-file'. In that case,
+if `inhibit-local-variables' is non-`nil' we require confirmation before
+processing a local variables spec. If you run `normal-mode' explicitly,
+confirmation is never required."
+ (interactive)
+ (or find-file (funcall (or default-major-mode 'fundamental-mode)))
+ (condition-case err
+ (set-auto-mode)
+ (error (message "File mode specification error: %s"
+ (prin1-to-string err))))
+ (condition-case err
+ (hack-local-variables (not find-file))
+ (error (message "File local-variables error: %s"
+ (prin1-to-string err)))))
+
+;(defvar auto-mode-alist ...) now in loaddefs.el
+(defun set-auto-mode ()
+ "Select major mode appropriate for current buffer.
+May base decision on visited file name (See variable auto-mode-list)
+or on buffer contents (-*- line or local variables spec), but does not look
+for the \"mode:\" local variable. For that, use hack-local-variables."
+ ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*-
+ (let (beg end mode)
+ (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n")
+ (if (and (search-forward "-*-" (save-excursion (end-of-line) (point)) t)
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (search-forward "-*-" (save-excursion (end-of-line) (point)) t))
+ (progn
+ (forward-char -3)
+ (skip-chars-backward " \t")
+ (setq end (point))
+ (goto-char beg)
+ (if (search-forward ":" end t)
+ (progn
+ (goto-char beg)
+ (if (let ((case-fold-search t))
+ (search-forward "mode:" end t))
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (if (search-forward ";" end t)
+ (forward-char -1)
+ (goto-char end))
+ (skip-chars-backward " \t")
+ (setq mode (buffer-substring beg (point))))))
+ (setq mode (buffer-substring beg end)))))
+ (funcall (intern (concat (downcase mode) "-mode")))
+ (let ((alist auto-mode-alist)
+ (name buffer-file-name))
+ (let ((case-fold-search (eq system-type 'vax-vms)))
+ ;; Remove backup-suffixes from file name.
+ (setq name (file-name-sans-versions name))
+ ;; Find first matching alist entry.
+ (while (and (not mode) alist)
+ (if (string-match (car (car alist)) name)
+ (setq mode (cdr (car alist))))
+ (setq alist (cdr alist))))
+ (if mode (funcall mode)))))))
+
+(defun hack-local-variables (&optional force)
+ "Parse, and bind or evaluate as appropriate, any local variables
+for current buffer."
+ ;; Look for "Local variables:" line in last page.
+ (save-excursion
+ (goto-char (point-max))
+ (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
+ (if (let ((case-fold-search t))
+ (and (search-forward "Local Variables:" nil t)
+ (or (not inhibit-local-variables)
+ force
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (save-excursion
+ (beginning-of-line)
+ (set-window-start (selected-window) (point)))
+ (y-or-n-p (format "Set local variables as specified at end of %s? "
+ (file-name-nondirectory buffer-file-name)))))))
+ (let ((continue t)
+ prefix prefixlen suffix beg)
+ ;; The prefix is what comes before "local variables:" in its line.
+ ;; The suffix is what comes after "local variables:" in its line.
+ (skip-chars-forward " \t")
+ (or (eolp)
+ (setq suffix (buffer-substring (point)
+ (progn (end-of-line) (point)))))
+ (goto-char (match-beginning 0))
+ (or (bolp)
+ (setq prefix
+ (buffer-substring (point)
+ (progn (beginning-of-line) (point)))))
+ (if prefix (setq prefixlen (length prefix)
+ prefix (regexp-quote prefix)))
+ (if suffix (setq suffix (concat (regexp-quote suffix) "$")))
+ (while continue
+ ;; Look at next local variable spec.
+ (if selective-display (re-search-forward "[\n\C-m]")
+ (forward-line 1))
+ ;; Skip the prefix, if any.
+ (if prefix
+ (if (looking-at prefix)
+ (forward-char prefixlen)
+ (error "Local variables entry is missing the prefix")))
+ ;; Find the variable name; strip whitespace.
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (skip-chars-forward "^:\n")
+ (if (eolp) (error "Missing colon in local variables entry"))
+ (skip-chars-backward " \t")
+ (let* ((str (buffer-substring beg (point)))
+ (var (read str))
+ val)
+ ;; Setting variable named "end" means end of list.
+ (if (string-equal (downcase str) "end")
+ (setq continue nil)
+ ;; Otherwise read the variable value.
+ (skip-chars-forward "^:")
+ (forward-char 1)
+ (setq val (read (current-buffer)))
+ (skip-chars-backward "\n")
+ (skip-chars-forward " \t")
+ (or (if suffix (looking-at suffix) (eolp))
+ (error "Local variables entry is terminated incorrectly"))
+ ;; Set the variable. "Variables" mode and eval are funny.
+ (cond ((eq var 'mode)
+ (funcall (intern (concat (downcase (symbol-name val))
+ "-mode"))))
+ ((eq var 'eval)
+ (if (string= (user-login-name) "root")
+ (message "Ignoring `eval:' in file's local variables")
+ (eval val)))
+ (t (make-local-variable var)
+ (set var val))))))))))
+\f
+(defun set-visited-file-name (filename)
+ "Change name of file visited in current buffer to FILENAME.
+The next time the buffer is saved it will go in the newly specified file.
+nil or empty string as argument means make buffer not be visiting any file.
+Remember to delete the initial contents of the minibuffer
+if you wish to pass an empty string as the argument."
+ (interactive "FSet visited file name: ")
+ (if filename
+ (setq filename
+ (if (string-equal filename "")
+ nil
+ (expand-file-name filename))))
+ (or (equal filename buffer-file-name)
+ (null filename)
+ (progn
+ (lock-buffer filename)
+ (unlock-buffer)))
+ (setq buffer-file-name filename)
+ (if filename
+ (let ((new-name (file-name-nondirectory buffer-file-name)))
+ (if (string= new-name "")
+ (error "Empty file name"))
+ (if (eq system-type 'vax-vms)
+ (setq new-name (downcase new-name)))
+ (setq default-directory (file-name-directory buffer-file-name))
+ (or (get-buffer new-name) (rename-buffer new-name))))
+ (setq buffer-backed-up nil)
+ (clear-visited-file-modtime)
+ (kill-local-variable 'write-file-hooks)
+ (kill-local-variable 'revert-buffer-function)
+ ;; Rename the auto-save file to go with the new visited name.
+ ;; If auto-save was not already on, turn it on if appropriate.
+ (if buffer-auto-save-file-name
+ (rename-auto-save-file)
+ (auto-save-mode (and buffer-file-name auto-save-default)))
+ (if buffer-file-name
+ (set-buffer-modified-p t)))
+
+(defun write-file (filename)
+ "Write current buffer into file FILENAME.
+Makes buffer visit that file, and marks it not modified."
+ (interactive "FWrite file: ")
+ (or (null filename) (string-equal filename "")
+ (set-visited-file-name filename))
+ (set-buffer-modified-p t)
+ (save-buffer))
+\f
+(defun backup-buffer ()
+ "Make a backup of the disk file visited by the current buffer, if appropriate.
+This is normally done before saving the buffer the first time.
+If the value is non-nil, it is the result of `file-modes' on the original file;
+this means that the caller, after saving the buffer, should change the modes
+of the new file to agree with the old modes."
+ (and make-backup-files
+ (not buffer-backed-up)
+ (file-exists-p buffer-file-name)
+ (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
+ '(?- ?l))
+ (or (< (length buffer-file-name) 5)
+ (not (string-equal "/tmp/" (substring buffer-file-name 0 5))))
+ (condition-case ()
+ (let* ((backup-info (find-backup-file-name buffer-file-name))
+ (backupname (car backup-info))
+ (targets (cdr backup-info))
+ setmodes)
+; (if (file-directory-p buffer-file-name)
+; (error "Cannot save buffer in directory %s" buffer-file-name))
+ (condition-case ()
+ (if (or file-precious-flag
+ (file-symlink-p buffer-file-name)
+ backup-by-copying
+ (and backup-by-copying-when-linked
+ (> (file-nlinks buffer-file-name) 1))
+ (and backup-by-copying-when-mismatch
+ (let ((attr (file-attributes buffer-file-name)))
+ (or (nth 9 attr)
+ (/= (nth 2 attr) (user-uid))))))
+ (copy-file buffer-file-name backupname t t)
+ (condition-case ()
+ (delete-file backupname)
+ (file-error nil))
+ (rename-file buffer-file-name backupname t)
+ (setq setmodes (file-modes backupname)))
+ (file-error
+ ;; If trouble writing the backup, write it in ~.
+ (setq backupname (expand-file-name "~/%backup%~"))
+ (message "Cannot write backup file; backing up in ~/%%backup%%~")
+ (sleep-for 1)
+ (copy-file buffer-file-name backupname t t)))
+ (setq buffer-backed-up t)
+ (if (and targets
+ (or trim-versions-without-asking
+ (y-or-n-p (format "Delete excess backup versions of %s? "
+ buffer-file-name))))
+ (while targets
+ (condition-case ()
+ (delete-file (car targets))
+ (file-error nil))
+ (setq targets (cdr targets))))
+ setmodes)
+ (file-error nil))))
+
+(defun file-name-sans-versions (name)
+ "Return FILENAME sans backup versions or strings.
+This is a separate procedure so your site-init or startup file can
+redefine it."
+ (substring name 0
+ (if (eq system-type 'vax-vms)
+ (or (string-match ";[0-9]+\\'" name)
+ (string-match ".[0-9]+\\'" name)
+ (length name))
+ (or (string-match "\\.~[0-9]+~\\'" name)
+ (string-match "~\\'" name)
+ (length name)))))
+
+(defun make-backup-file-name (file)
+ "Create the non-numeric backup file name for FILE.
+This is a separate function so you can redefine it for customization."
+ (concat file "~"))
+
+(defun backup-file-name-p (file)
+ "Return non-nil if FILE is a backup file name (numeric or not).
+This is a separate function so you can redefine it for customization.
+You may need to redefine file-name-sans-versions as well."
+ (string-match "~$" file))
+
+;; I believe there is no need to alter this behavior for VMS;
+;; since backup files are not made on VMS, it should not get called.
+(defun find-backup-file-name (fn)
+ "Find a file name for a backup file, and suggestions for deletions.
+Value is a list whose car is the name for the backup file
+ and whose cdr is a list of old versions to consider deleting now."
+ (if (eq version-control 'never)
+ (list (make-backup-file-name fn))
+ (let* ((base-versions (concat (file-name-nondirectory fn) ".~"))
+ (bv-length (length base-versions))
+ (possibilities (file-name-all-completions
+ base-versions
+ (file-name-directory fn)))
+ (versions (sort (mapcar 'backup-extract-version possibilities)
+ '<))
+ (high-water-mark (apply 'max (cons 0 versions)))
+ (deserve-versions-p
+ (or version-control
+ (> high-water-mark 0)))
+ (number-to-delete (- (length versions)
+ kept-old-versions kept-new-versions -1)))
+ (if (not deserve-versions-p)
+ (list (make-backup-file-name fn))
+ (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~")
+ (if (> number-to-delete 0)
+ (mapcar (function (lambda (n)
+ (concat fn ".~" (int-to-string n) "~")))
+ (let ((v (nthcdr kept-old-versions versions)))
+ (rplacd (nthcdr (1- number-to-delete) v) ())
+ v))))))))
+
+(defun backup-extract-version (fn)
+ (if (and (string-match "[0-9]+~$" fn bv-length)
+ (= (match-beginning 0) bv-length))
+ (string-to-int (substring fn bv-length -1))
+ 0))
+
+(defun file-nlinks (filename)
+ "Return number of names file FILENAME has."
+ (car (cdr (file-attributes filename))))
+\f
+(defun save-buffer (&optional args)
+ "Save current buffer in visited file if modified. Versions described below.
+
+By default, makes the previous version into a backup file
+ if previously requested or if this is the first save.
+With 1 or 3 \\[universal-argument]'s, marks this version
+ to become a backup when the next save is done.
+With 2 or 3 \\[universal-argument]'s,
+ unconditionally makes the previous version into a backup file.
+With argument of 0, never makes the previous version into a backup file.
+
+If a file's name is FOO, the names of its numbered backup versions are
+ FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
+Numeric backups (rather than FOO~) will be made if value of
+ `version-control' is not the atom `never' and either there are already
+ numeric versions of the file being backed up, or `version-control' is
+ non-nil.
+We don't want excessive versions piling up, so there are variables
+ `kept-old-versions', which tells Emacs how many oldest versions to keep,
+ and `kept-new-versions', which tells how many newest versions to keep.
+ Defaults are 2 old versions and 2 new.
+`dired-kept-versions' controls dired's clean-directory (.) command.
+If `trim-versions-without-asking' is nil, system will query user
+ before trimming versions. Otherwise it does it silently."
+ (interactive "p")
+ (let ((modp (buffer-modified-p))
+ (large (> (buffer-size) 50000))
+ (make-backup-files (and make-backup-files (not (eq args 0)))))
+ (and modp (memq args '(16 64)) (setq buffer-backed-up nil))
+ (if (and modp large) (message "Saving file %s..." (buffer-file-name)))
+ (basic-save-buffer)
+ (and modp (memq args '(4 64)) (setq buffer-backed-up nil))))
+
+(defun delete-auto-save-file-if-necessary ()
+ "Delete the auto-save filename for the current buffer (if it has one)
+if variable delete-auto-save-files is non-nil."
+ (and buffer-auto-save-file-name delete-auto-save-files
+ (not (string= buffer-file-name buffer-auto-save-file-name))
+ (progn
+ (condition-case ()
+ (delete-file buffer-auto-save-file-name)
+ (file-error nil))
+ (set-buffer-auto-saved))))
+
+(defun basic-save-buffer ()
+ "Save the current buffer in its visited file, if it has been modified."
+ (interactive)
+ (if (buffer-modified-p)
+ (let (setmodes tempsetmodes)
+ (or buffer-file-name
+ (progn
+ (setq buffer-file-name
+ (expand-file-name (read-file-name "File to save in: ") nil)
+ default-directory (file-name-directory buffer-file-name))
+ (auto-save-mode auto-save-default)))
+ (if (not (file-writable-p buffer-file-name))
+ (if (yes-or-no-p
+ (format "File %s is write-protected; try to save anyway? "
+ (file-name-nondirectory buffer-file-name)))
+ (setq tempsetmodes t)
+ (error
+ "Attempt to save to a file which you aren't allowed to write")))
+ (or (verify-visited-file-modtime (current-buffer))
+ (not (file-exists-p buffer-file-name))
+ (yes-or-no-p
+ "Disk file has changed since visited or saved. Save anyway? ")
+ (error "Save not confirmed"))
+ (or buffer-backed-up
+ (setq setmodes (backup-buffer)))
+ (save-restriction
+ (widen)
+ (and (> (point-max) 1)
+ (/= (char-after (1- (point-max))) ?\n)
+ (or (eq require-final-newline t)
+ (and require-final-newline
+ (yes-or-no-p
+ (format "Buffer %s does not end in newline. Add one? "
+ (buffer-name)))))
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n)))
+ (let ((hooks write-file-hooks)
+ (done nil))
+ (while (and hooks
+ (not (setq done (funcall (car hooks)))))
+ (setq hooks (cdr hooks)))
+ ;; If a hook returned t, file is already "written".
+ (cond ((not done)
+ (if file-precious-flag
+ ;; If file is precious, rename it away before
+ ;; overwriting it.
+ (let ((rename t) nodelete
+ (file (concat buffer-file-name "#")))
+ (condition-case ()
+ (progn (rename-file buffer-file-name file t)
+ (setq setmodes (file-modes file)))
+ (file-error (setq rename nil nodelete t)))
+ (unwind-protect
+ (progn (clear-visited-file-modtime)
+ (write-region (point-min) (point-max)
+ buffer-file-name nil t)
+ (setq rename nil))
+ ;; If rename is still t, writing failed.
+ ;; So rename the old file back to original name,
+ (if rename
+ (progn
+ (rename-file file buffer-file-name t)
+ (clear-visited-file-modtime))
+ ;; Otherwise we don't need the original file,
+ ;; so flush it. Unless we already lost it.
+ (or nodelete
+ (condition-case ()
+ (delete-file file)
+ (error nil))))))
+ ;; If file not writable, see if we can make it writable
+ ;; temporarily while we write it.
+ ;; But no need to do so if we have just backed it up
+ ;; (setmodes is set) because that says we're superseding.
+ (cond ((and tempsetmodes (not setmodes))
+ ;; Change the mode back, after writing.
+ (setq setmodes (file-modes buffer-file-name))
+ (set-file-modes buffer-file-name 511)))
+ (write-region (point-min) (point-max)
+ buffer-file-name nil t)))))
+ (if setmodes
+ (condition-case ()
+ (set-file-modes buffer-file-name setmodes)
+ (error nil))))
+ (delete-auto-save-file-if-necessary))
+ (message "(No changes need to be saved)")))
+
+(defun save-some-buffers (&optional arg exiting)
+ "Save some modified file-visiting buffers. Asks user about each one.
+With argument, saves all with no questions."
+ (interactive "P")
+ (let (considered (list (buffer-list)))
+ (while list
+ (let ((buffer (car list)))
+ (and (buffer-modified-p buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (and
+ (or buffer-file-name
+ (and exiting buffer-offer-save (> (buffer-size) 0)))
+ (setq considered t)
+ (or arg
+ (y-or-n-p (if buffer-file-name
+ (format "Save file %s? "
+ buffer-file-name)
+ (format "Save buffer %s? " (buffer-name)))))
+ (condition-case ()
+ (save-buffer)
+ (error nil))))))
+ (setq list (cdr list)))
+ (and save-abbrevs abbrevs-changed
+ (progn
+ (setq considered t)
+ (if (or arg
+ (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
+ (write-abbrev-file nil))
+ ;; Don't keep bothering user if he says no.
+ (setq abbrevs-changed nil)))
+ (if considered
+ (message "")
+ (message "(No files need saving)"))))
+\f
+(defun not-modified ()
+ "Mark current buffer as unmodified, not needing to be saved."
+ (interactive)
+ (message "Modification-flag cleared")
+ (set-buffer-modified-p nil))
+
+(defun toggle-read-only ()
+ "Change whether this buffer is visiting its file read-only."
+ (interactive)
+ (setq buffer-read-only (not buffer-read-only))
+ ;; Force mode-line redisplay
+ (set-buffer-modified-p (buffer-modified-p)))
+
+(defun insert-file (filename)
+ "Insert contents of file FILENAME into buffer after point.
+Set mark after the inserted text."
+ (interactive "fInsert file: ")
+ (let ((tem (insert-file-contents filename)))
+ (push-mark (+ (point) (car (cdr tem))))))
+
+(defun append-to-file (start end filename)
+ "Append the contents of the region to the end of file FILENAME.
+When called from a function, expects three arguments,
+START, END and FILENAME. START and END are buffer positions
+saying what text to write."
+ (interactive "r\nFAppend to file: ")
+ (write-region start end filename t))
+
+(defvar revert-buffer-function nil
+ "Function to use to revert this buffer, or nil to do the default.")
+
+(defun revert-buffer (&optional arg noconfirm)
+ "Replace the buffer text with the text of the visited file on disk.
+This undoes all changes since the file was visited or saved.
+If latest auto-save file is more recent than the visited file,
+asks user whether to use that instead.
+First argument (optional) non-nil means don't offer to use auto-save file.
+ This is the prefix arg when called interactively.
+
+Second argument (optional) non-nil means don't ask for confirmation at all.
+
+If revert-buffer-function's value is non-nil, it is called to do the work."
+ (interactive "P")
+ (if revert-buffer-function
+ (funcall revert-buffer-function arg noconfirm)
+ (let* ((opoint (point))
+ (auto-save-p (and (null arg) (recent-auto-save-p)
+ buffer-auto-save-file-name
+ (file-readable-p buffer-auto-save-file-name)
+ (y-or-n-p
+ "Buffer has been auto-saved recently. Revert from auto-save file? ")))
+ (file-name (if auto-save-p
+ buffer-auto-save-file-name
+ buffer-file-name)))
+ (cond ((null file-name)
+ (error "Buffer does not seem to be associated with any file"))
+ ((not (file-exists-p file-name))
+ (error "File %s no longer exists!" file-name))
+ ((or noconfirm
+ (yes-or-no-p (format "Revert buffer from file %s? "
+ file-name)))
+ ;; If file was backed up but has changed since,
+ ;; we shd make another backup.
+ (and (not auto-save-p)
+ (not (verify-visited-file-modtime (current-buffer)))
+ (setq buffer-backed-up nil))
+ ;; Discard all the undo information.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (let ((buffer-read-only nil)
+ ;; Don't record undo info for the revert itself.
+ ;; Doing so chews up too much storage.
+ (buffer-undo-list t))
+ ;; Bind buffer-file-name to nil
+ ;; so that we don't try to lock the file.
+ (let ((buffer-file-name nil))
+ (or auto-save-p
+ (unlock-buffer))
+ (erase-buffer))
+ (insert-file-contents file-name (not auto-save-p)))
+ (goto-char (min opoint (point-max)))
+ (after-find-file nil)
+ t)))))
+
+(defun recover-file (file)
+ "Visit file FILE, but get contents from its last auto-save file."
+ (interactive "FRecover file: ")
+ (setq file (expand-file-name file))
+ (if (auto-save-file-name-p file) (error "%s is an auto-save file" file))
+ (let ((file-name (let ((buffer-file-name file))
+ (make-auto-save-file-name))))
+ (cond ((not (file-newer-than-file-p file-name file))
+ (error "Auto-save file %s not current" file-name))
+ ((save-window-excursion
+ (if (not (eq system-type 'vax-vms))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-flush-undo standard-output)
+ (call-process "ls" nil standard-output nil
+ "-l" file file-name)))
+ (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+ (switch-to-buffer (find-file-noselect file t))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert-file-contents file-name nil))
+ (after-find-file nil))
+ (t (error "Recover-file cancelled."))))
+ (setq buffer-auto-save-file-name nil)
+ (message "Auto-save off in this buffer till you do M-x auto-save-mode."))
+
+(defun kill-some-buffers ()
+ "For each buffer, ask whether to kill it."
+ (interactive)
+ (let ((list (buffer-list)))
+ (while list
+ (let* ((buffer (car list))
+ (name (buffer-name buffer)))
+ (and (not (string-equal name ""))
+ (/= (aref name 0) ? )
+ (yes-or-no-p
+ (format "Buffer %s %s. Kill? "
+ name
+ (if (buffer-modified-p buffer)
+ "HAS BEEN EDITED" "is unmodified")))
+ (kill-buffer buffer)))
+ (setq list (cdr list)))))
+\f
+(defun auto-save-mode (arg)
+ "Toggle auto-saving of contents of current buffer.
+With arg, turn auto-saving on if arg is positive, else off."
+ (interactive "P")
+ (setq buffer-auto-save-file-name
+ (and (if (null arg)
+ (not buffer-auto-save-file-name)
+ (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))
+ (if (and buffer-file-name auto-save-visited-file-name
+ (not buffer-read-only))
+ buffer-file-name
+ (make-auto-save-file-name))))
+ (if (interactive-p)
+ (message "Auto-save %s (in this buffer)"
+ (if buffer-auto-save-file-name "on" "off")))
+ buffer-auto-save-file-name)
+
+(defun rename-auto-save-file ()
+ "Adjust current buffer's auto save file name for current conditions.
+Also rename any existing auto save file."
+ (let ((osave buffer-auto-save-file-name))
+ (setq buffer-auto-save-file-name
+ (make-auto-save-file-name))
+ (if (and osave buffer-auto-save-file-name
+ (not (string= buffer-auto-save-file-name buffer-file-name))
+ (not (string= buffer-auto-save-file-name osave))
+ (file-exists-p osave))
+ (rename-file osave buffer-auto-save-file-name t))))
+
+(defun make-auto-save-file-name ()
+ "Return file name to use for auto-saves of current buffer.
+Does not consider auto-save-visited-file-name; that is checked
+before calling this function.
+You can redefine this for customization.
+See also auto-save-file-name-p."
+ (if buffer-file-name
+ (concat (file-name-directory buffer-file-name)
+ "#"
+ (file-name-nondirectory buffer-file-name)
+ "#")
+ (expand-file-name (concat "#%" (buffer-name) "#"))))
+
+(defun auto-save-file-name-p (filename)
+ "Return non-nil if FILENAME can be yielded by make-auto-save-file-name.
+FILENAME should lack slashes.
+You can redefine this for customization."
+ (string-match "^#.*#$" filename))
+\f
+(defconst list-directory-brief-switches "-CF"
+ "*Switches for list-directory to pass to `ls' for brief listing,")
+(defconst list-directory-verbose-switches "-l"
+ "*Switches for list-directory to pass to `ls' for verbose listing,")
+
+(defun list-directory (dirname &optional verbose)
+ "Display a list of files in or matching DIRNAME, a la `ls'.
+DIRNAME is globbed by the shell if necessary.
+Prefix arg (second arg if noninteractive) means supply -l switch to `ls'.
+Actions controlled by variables list-directory-brief-switches
+ and list-directory-verbose-switches."
+ (interactive (let ((pfx current-prefix-arg))
+ (list (read-file-name (if pfx "List directory (verbose): "
+ "List directory (brief): ")
+ nil default-directory nil)
+ pfx)))
+ (let ((switches (if verbose list-directory-verbose-switches
+ list-directory-brief-switches))
+ full-dir-p)
+ (or dirname (setq dirname default-directory))
+ (if (file-directory-p dirname)
+ (progn
+ (setq full-dir-p t)
+ (or (string-match "/$" dirname)
+ (setq dirname (concat dirname "/")))))
+ (setq dirname (expand-file-name dirname))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-flush-undo standard-output)
+ (princ "Directory ")
+ (princ dirname)
+ (terpri)
+ (if full-dir-p
+ (call-process "ls" nil standard-output nil
+ switches dirname)
+ (let ((default-directory (file-name-directory dirname)))
+ (call-process shell-file-name nil standard-output nil
+ "-c" (concat "exec ls "
+ switches " "
+ (file-name-nondirectory dirname))))))))
+
+(defun save-buffers-kill-emacs (&optional arg)
+ "Offer to save each buffer, then kill this Emacs fork.
+With prefix arg, silently save all file-visiting buffers, then kill."
+ (interactive "P")
+ (save-some-buffers arg t)
+ (and (or (not (memq t (mapcar (function
+ (lambda (buf) (and (buffer-file-name buf)
+ (buffer-modified-p buf))))
+ (buffer-list))))
+ (yes-or-no-p "Modified buffers exist; exit anyway? "))
+ (or (not (fboundp 'process-list))
+ ;; process-list is not defined on VMS.
+ (let ((processes (process-list))
+ active)
+ (while processes
+ (and (memq (process-status (car processes)) '(run stop))
+ (let ((val (process-kill-without-query (car processes))))
+ (process-kill-without-query (car processes) val)
+ val)
+ (setq active t))
+ (setq processes (cdr processes)))
+ (or (not active)
+ (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
+ (kill-emacs)))
+\f
+(define-key ctl-x-map "\C-f" 'find-file)
+(define-key ctl-x-map "\C-q" 'toggle-read-only)
+(define-key ctl-x-map "\C-r" 'find-file-read-only)
+(define-key ctl-x-map "\C-v" 'find-alternate-file)
+(define-key ctl-x-map "\C-s" 'save-buffer)
+(define-key ctl-x-map "s" 'save-some-buffers)
+(define-key ctl-x-map "\C-w" 'write-file)
+(define-key ctl-x-map "i" 'insert-file)
+(define-key esc-map "~" 'not-modified)
+(define-key ctl-x-map "\C-d" 'list-directory)
+(define-key ctl-x-map "\C-c" 'save-buffers-kill-emacs)
+
+(defvar ctl-x-4-map (make-keymap)
+ "Keymap for subcommands of C-x 4")
+(fset 'ctl-x-4-prefix ctl-x-4-map)
+(define-key ctl-x-map "4" 'ctl-x-4-prefix)
+(define-key ctl-x-4-map "f" 'find-file-other-window)
+(define-key ctl-x-4-map "\C-f" 'find-file-other-window)
+(define-key ctl-x-4-map "b" 'switch-to-buffer-other-window)
--- /dev/null
+;; Fill commands for Emacs
+;; Copyright (C) 1985, 1986 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.
+
+
+(defun set-fill-prefix ()
+ "Set the fill-prefix to the current line up to point.
+Filling expects lines to start with the fill prefix
+and reinserts the fill prefix in each resulting line."
+ (interactive)
+ (setq fill-prefix (buffer-substring
+ (save-excursion (beginning-of-line) (point))
+ (point)))
+ (if (equal fill-prefix "")
+ (setq fill-prefix nil))
+ (if fill-prefix
+ (message "fill-prefix: \"%s\"" fill-prefix)
+ (message "fill-prefix cancelled")))
+
+(defun fill-region-as-paragraph (from to &optional justify-flag)
+ "Fill region as one paragraph: break lines to fit fill-column.
+Prefix arg means justify too.
+From program, pass args FROM, TO and JUSTIFY-FLAG."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (skip-chars-forward "\n")
+ (narrow-to-region (point) (point-max))
+ (setq from (point))
+ (let ((fpre (and fill-prefix (not (equal fill-prefix ""))
+ (regexp-quote fill-prefix))))
+ ;; Delete the fill prefix from every line except the first.
+ ;; The first line may not even have a fill prefix.
+ (and fpre
+ (progn
+ (if (>= (length fill-prefix) fill-column)
+ (error "fill-prefix too long for specified width"))
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (not (eobp))
+ (if (looking-at fpre)
+ (delete-region (point) (match-end 0)))
+ (forward-line 1))
+ (goto-char (point-min))
+ (and (looking-at fpre) (forward-char (length fill-prefix)))
+ (setq from (point)))))
+ ;; from is now before the text to fill,
+ ;; but after any fill prefix on the first line.
+
+ ;; Make sure sentences ending at end of line get an extra space.
+ (goto-char from)
+ (while (re-search-forward "[.?!][])""']*$" nil t)
+ (insert ? ))
+ ;; The change all newlines to spaces.
+ (subst-char-in-region from (point-max) ?\n ?\ )
+ ;; Flush excess spaces, except in the paragraph indentation.
+ (goto-char from)
+ (skip-chars-forward " \t")
+ (while (re-search-forward " *" nil t)
+ (delete-region
+ (+ (match-beginning 0)
+ (if (save-excursion
+ (skip-chars-backward " ])\"'")
+ (memq (preceding-char) '(?. ?? ?!)))
+ 2 1))
+ (match-end 0)))
+ (goto-char (point-max))
+ (delete-horizontal-space)
+ (insert " ")
+ (goto-char (point-min))
+ (let ((prefixcol 0))
+ (while (not (eobp))
+ (move-to-column (1+ fill-column))
+ (if (eobp)
+ nil
+ (skip-chars-backward "^ \n")
+ (if (if (zerop prefixcol) (bolp) (>= prefixcol (current-column)))
+ (skip-chars-forward "^ \n")
+ (forward-char -1)))
+ (delete-horizontal-space)
+ (insert ?\n)
+ (and (not (eobp)) fill-prefix (not (equal fill-prefix ""))
+ (progn
+ (insert fill-prefix)
+ (setq prefixcol (current-column))))
+ (and justify-flag (not (eobp))
+ (progn
+ (forward-line -1)
+ (justify-current-line)
+ (forward-line 1)))))))
+
+(defun fill-paragraph (arg)
+ "Fill paragraph at or after point.
+Prefix arg means justify as well."
+ (interactive "P")
+ (save-excursion
+ (forward-paragraph)
+ (or (bolp) (newline 1))
+ (let ((end (point)))
+ (backward-paragraph)
+ (fill-region-as-paragraph (point) end arg))))
+
+(defun fill-region (from to &optional justify-flag)
+ "Fill each of the paragraphs in the region.
+Prefix arg (non-nil third arg, if called from program)
+means justify as well."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((initial (point))
+ (end (progn
+ (forward-paragraph 1) (point))))
+ (forward-paragraph -1)
+ (if (>= (point) initial)
+ (fill-region-as-paragraph (point) end justify-flag)
+ (goto-char end))))))
+
+(defun justify-current-line ()
+ "Add spaces to line point is in, so it ends at fill-column."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let (ncols beg)
+ (beginning-of-line)
+ (forward-char (length fill-prefix))
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (end-of-line)
+ (narrow-to-region beg (point))
+ (goto-char beg)
+ (while (re-search-forward " *" nil t)
+ (delete-region
+ (+ (match-beginning 0)
+ (if (save-excursion
+ (skip-chars-backward " ])\"'")
+ (memq (preceding-char) '(?. ?? ?!)))
+ 2 1))
+ (match-end 0)))
+ (goto-char beg)
+ (while (re-search-forward "[.?!][])""']*\n" nil t)
+ (forward-char -1)
+ (insert ? ))
+ (goto-char (point-max))
+ (setq ncols (- fill-column (current-column)))
+ (if (search-backward " " nil t)
+ (while (> ncols 0)
+ (let ((nmove (+ 3 (% (random) 3))))
+ (while (> nmove 0)
+ (or (search-backward " " nil t)
+ (progn
+ (goto-char (point-max))
+ (search-backward " ")))
+ (skip-chars-backward " ")
+ (setq nmove (1- nmove))))
+ (insert " ")
+ (skip-chars-backward " ")
+ (setq ncols (1- ncols))))))))
+\f
+(defun fill-individual-paragraphs (min max &optional justifyp mailp)
+ "Fill each paragraph in region according to its individual fill prefix.
+Calling from a program, pass range to fill as first two arguments.
+Optional third and fourth arguments JUSTIFY-FLAG and MAIL-FLAG:
+JUSTIFY-FLAG to justify paragraphs (prefix arg),
+MAIL-FLAG for a mail message, i. e. don't fill header lines."
+ (interactive "r\nP")
+ (let (fill-prefix)
+ (save-restriction
+ (save-excursion
+ (narrow-to-region min max)
+ (goto-char (point-min))
+ (while (progn
+ (skip-chars-forward " \t\n")
+ (not (eobp)))
+ (setq fill-prefix (buffer-substring (point) (progn (beginning-of-line) (point))))
+ (let ((fin (save-excursion (forward-paragraph) (point)))
+ (start (point)))
+ (if mailp
+ (while (re-search-forward "^[ \t]*[^ \t\n]*:" fin t)
+ (forward-line 1)))
+ (cond ((= start (point))
+ (fill-region-as-paragraph (point) fin justifyp)
+ (goto-char fin)))))))))
+
--- /dev/null
+;; Copyright (C) 1986 Free Software Foundation, Inc.
+;; Author Bill Rosenblatt
+
+;; 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.
+
+;; Floating point arithmetic package.
+;;
+;; Floating point numbers are represented by dot-pairs (mant . exp)
+;; where mant is the 24-bit signed integral mantissa and exp is the
+;; base 2 exponent.
+;;
+;; Emacs LISP supports a 24-bit signed integer data type, which has a
+;; range of -(2**23) to +(2**23)-1, or -8388608 to 8388607 decimal.
+;; This gives six significant decimal digit accuracy. Exponents can
+;; be anything in the range -(2**23) to +(2**23)-1.
+;;
+;; User interface:
+;; function f converts from integer to floating point
+;; function string-to-float converts from string to floating point
+;; function fint converts a floating point to integer (with truncation)
+;; function float-to-string converts from floating point to string
+;;
+;; Caveats:
+;; - Exponents outside of the range of +/-100 or so will cause certain
+;; functions (especially conversion routines) to take forever.
+;; - Very little checking is done for fixed point overflow/underflow.
+;; - No checking is done for over/underflow of the exponent
+;; (hardly necessary when exponent can be 2**23).
+;;
+;;
+;; Bill Rosenblatt
+;; June 20, 1986
+;;
+
+(provide 'float)
+
+;; fundamental implementation constants
+(defconst exp-base 2
+ "Base of exponent in this floating point representation.")
+
+(defconst mantissa-bits 24
+ "Number of significant bits in this floating point representation.")
+
+(defconst decimal-digits 6
+ "Number of decimal digits expected to be accurate.")
+
+(defconst expt-digits 2
+ "Maximum permitted digits in a scientific notation exponent.")
+
+;; other constants
+(defconst maxbit (1- mantissa-bits)
+ "Number of highest bit")
+
+(defconst mantissa-maxval (1- (ash 1 maxbit))
+ "Maximum permissable value of mantissa")
+
+(defconst mantissa-minval (ash 1 maxbit)
+ "Minimum permissable value of mantissa")
+
+(defconst floating-point-regexp
+ "^[ \t]*\\(-?\\)\\([0-9]*\\)\
+\\(\\.\\([0-9]*\\)\\|\\)\
+\\(\\(\\([Ee]\\)\\(-?\\)\\([0-9][0-9]*\\)\\)\\|\\)[ \t]*$"
+ "Regular expression to match floating point numbers. Extract matches:
+1 - minus sign
+2 - integer part
+4 - fractional part
+8 - minus sign for power of ten
+9 - power of ten
+")
+
+(defconst high-bit-mask (ash 1 maxbit)
+ "Masks all bits except the high-order (sign) bit.")
+
+(defconst second-bit-mask (ash 1 (1- maxbit))
+ "Masks all bits except the highest-order magnitude bit")
+
+;; various useful floating point constants
+(setq _f0 '(0 . 1))
+
+(setq _f1/2 '(4194304 . -23))
+
+(setq _f1 '(4194304 . -22))
+
+(setq _f10 '(5242880 . -19))
+
+;; support for decimal conversion routines
+(setq powers-of-10 (make-vector (1+ decimal-digits) _f1))
+(aset powers-of-10 1 _f10)
+(aset powers-of-10 2 '(6553600 . -16))
+(aset powers-of-10 3 '(8192000 . -13))
+(aset powers-of-10 4 '(5120000 . -9))
+(aset powers-of-10 5 '(6400000 . -6))
+(aset powers-of-10 6 '(8000000 . -3))
+
+(setq all-decimal-digs-minval (aref powers-of-10 (1- decimal-digits))
+ highest-power-of-10 (aref powers-of-10 decimal-digits))
+
+(defun fashl (fnum) ; floating-point arithmetic shift left
+ (cons (ash (car fnum) 1) (1- (cdr fnum))))
+
+(defun fashr (fnum) ; floating point arithmetic shift right
+ (cons (ash (car fnum) -1) (1+ (cdr fnum))))
+
+(defun normalize (fnum)
+ (if (> (car fnum) 0) ; make sure next-to-highest bit is set
+ (while (zerop (logand (car fnum) second-bit-mask))
+ (setq fnum (fashl fnum)))
+ (if (< (car fnum) 0) ; make sure highest bit is set
+ (while (zerop (logand (car fnum) high-bit-mask))
+ (setq fnum (fashl fnum)))
+ (setq fnum _f0))) ; "standard 0"
+ fnum)
+
+(defun abs (n) ; integer absolute value
+ (if (natnump n) n (- n)))
+
+(defun fabs (fnum) ; re-normalize after taking abs value
+ (normalize (cons (abs (car fnum)) (cdr fnum))))
+
+(defun xor (a b) ; logical exclusive or
+ (and (or a b) (not (and a b))))
+
+(defun same-sign (a b) ; two f-p numbers have same sign?
+ (not (xor (natnump (car a)) (natnump (car b)))))
+
+(defun extract-match (str i) ; used after string-match
+ (condition-case ()
+ (substring str (match-beginning i) (match-end i))
+ (error "")))
+
+;; support for the multiplication function
+(setq halfword-bits (/ mantissa-bits 2) ; bits in a halfword
+ masklo (1- (ash 1 halfword-bits)) ; isolate the lower halfword
+ maskhi (lognot masklo) ; isolate the upper halfword
+ round-limit (ash 1 (/ halfword-bits 2)))
+
+(defun hihalf (n) ; return high halfword, shifted down
+ (ash (logand n maskhi) (- halfword-bits)))
+
+(defun lohalf (n) ; return low halfword
+ (logand n masklo))
+
+;; Visible functions
+
+;; Arithmetic functions
+(defun f+ (a1 a2)
+ "Returns the sum of two floating point numbers."
+ (let ((f1 (fmax a1 a2))
+ (f2 (fmin a1 a2)))
+ (if (same-sign a1 a2)
+ (setq f1 (fashr f1) ; shift right to avoid overflow
+ f2 (fashr f2)))
+ (normalize
+ (cons (+ (car f1) (ash (car f2) (- (cdr f2) (cdr f1))))
+ (cdr f1)))))
+
+(defun f- (a1 &optional a2) ; unary or binary minus
+ "Returns the difference of two floating point numbers."
+ (if a2
+ (f+ a1 (f- a2))
+ (normalize (cons (- (car a1)) (cdr a1)))))
+
+(defun f* (a1 a2) ; multiply in halfword chunks
+ "Returns the product of two floating point numbers."
+ (let* ((i1 (car (fabs a1)))
+ (i2 (car (fabs a2)))
+ (sign (not (same-sign a1 a2)))
+ (prodlo (+ (hihalf (* (lohalf i1) (lohalf i2)))
+ (lohalf (* (hihalf i1) (lohalf i2)))
+ (lohalf (* (lohalf i1) (hihalf i2)))))
+ (prodhi (+ (* (hihalf i1) (hihalf i2))
+ (hihalf (* (hihalf i1) (lohalf i2)))
+ (hihalf (* (lohalf i1) (hihalf i2)))
+ (hihalf prodlo))))
+ (if (> (lohalf prodlo) round-limit)
+ (setq prodhi (1+ prodhi))) ; round off truncated bits
+ (normalize
+ (cons (if sign (- prodhi) prodhi)
+ (+ (cdr (fabs a1)) (cdr (fabs a2)) mantissa-bits)))))
+
+(defun f/ (a1 a2) ; SLOW subtract-and-shift algorithm
+ "Returns the quotient of two floating point numbers."
+ (if (zerop (car a2)) ; if divide by 0
+ (signal 'arith-error (list "attempt to divide by zero" a1 a2))
+ (let ((bits (1- maxbit))
+ (quotient 0)
+ (dividend (car (fabs a1)))
+ (divisor (car (fabs a2)))
+ (sign (not (same-sign a1 a2))))
+ (while (natnump bits)
+ (if (< (- dividend divisor) 0)
+ (setq quotient (ash quotient 1))
+ (setq quotient (1+ (ash quotient 1))
+ dividend (- dividend divisor)))
+ (setq dividend (ash dividend 1)
+ bits (1- bits)))
+ (normalize
+ (cons (if sign (- quotient) quotient)
+ (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit)))))))
+
+(defun f% (a1 a2)
+ "Returns the remainder of first floating point number divided by second."
+ (f- a1 (f* (ftrunc (f/ a1 a2)) a2)))
+
+
+;; Comparison functions
+(defun f= (a1 a2)
+ "Returns t if two floating point numbers are equal, nil otherwise."
+ (equal a1 a2))
+
+(defun f> (a1 a2)
+ "Returns t if first floating point number is greater than second,
+nil otherwise."
+ (cond ((and (natnump (car a1)) (< (car a2) 0))
+ t) ; a1 nonnegative, a2 negative
+ ((and (> (car a1) 0) (<= (car a2) 0))
+ t) ; a1 positive, a2 nonpositive
+ ((and (<= (car a1) 0) (natnump (car a2)))
+ nil) ; a1 nonpos, a2 nonneg
+ ((/= (cdr a1) (cdr a2)) ; same signs. exponents differ
+ (> (cdr a1) (cdr a2))) ; compare the mantissas.
+ (t
+ (> (car a1) (car a2))))) ; same exponents.
+
+(defun f>= (a1 a2)
+ "Returns t if first floating point number is greater than or equal to
+second, nil otherwise."
+ (or (f> a1 a2) (f= a1 a2)))
+
+(defun f< (a1 a2)
+ "Returns t if first floating point number is less than second,
+nil otherwise."
+ (not (f>= a1 a2)))
+
+(defun f<= (a1 a2)
+ "Returns t if first floating point number is less than or equal to
+second, nil otherwise."
+ (not (f> a1 a2)))
+
+(defun f/= (a1 a2)
+ "Returns t if first floating point number is not equal to second,
+nil otherwise."
+ (not (f= a1 a2)))
+
+(defun fmin (a1 a2)
+ "Returns the minimum of two floating point numbers."
+ (if (f< a1 a2) a1 a2))
+
+(defun fmax (a1 a2)
+ "Returns the maximum of two floating point numbers."
+ (if (f> a1 a2) a1 a2))
+
+(defun fzerop (fnum)
+ "Returns t if the floating point number is zero, nil otherwise."
+ (= (car fnum) 0))
+
+(defun floatp (fnum)
+ "Returns t if the arg is a floating point number, nil otherwise."
+ (and (consp fnum) (integerp (car fnum)) (integerp (cdr fnum))))
+
+;; Conversion routines
+(defun f (int)
+ "Convert the integer argument to floating point, like a C cast operator."
+ (normalize (cons int '0)))
+
+(defun int-to-hex-string (int)
+ "Convert the integer argument to a C-style hexadecimal string."
+ (let ((shiftval -20)
+ (str "0x")
+ (hex-chars "0123456789ABCDEF"))
+ (while (<= shiftval 0)
+ (setq str (concat str (char-to-string
+ (aref hex-chars
+ (logand (lsh int shiftval) 15))))
+ shiftval (+ shiftval 4)))
+ str))
+
+(defun ftrunc (fnum) ; truncate fractional part
+ "Truncate the fractional part of a floating point number."
+ (cond ((natnump (cdr fnum)) ; it's all integer, return number as is
+ fnum)
+ ((<= (cdr fnum) (- maxbit)) ; it's all fractional, return 0
+ '(0 . 1))
+ (t ; otherwise mask out fractional bits
+ (let ((mant (car fnum)) (exp (cdr fnum)))
+ (normalize
+ (cons (if (natnump mant) ; if negative, use absolute value
+ (ash (ash mant exp) (- exp))
+ (- (ash (ash (- mant) exp) (- exp))))
+ exp))))))
+
+(defun fint (fnum) ; truncate and convert to integer
+ "Convert the floating point number to integer, with truncation,
+like a C cast operator."
+ (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf)))
+ (cond ((>= texp mantissa-bits) ; too high, return "maxint"
+ mantissa-maxval)
+ ((<= texp (- mantissa-bits)) ; too low, return "minint"
+ mantissa-minval)
+ (t ; in range
+ (ash tint texp))))) ; shift so that exponent is 0
+
+(defun float-to-string (fnum &optional sci)
+ "Convert the floating point number to a decimal string.
+Optional second argument non-nil means use scientific notation."
+ (let* ((value (fabs fnum)) (sign (< (car fnum) 0))
+ (power 0) (result 0) (str "")
+ (temp 0) (pow10 _f1))
+
+ (if (f= fnum _f0)
+ "0"
+ (if (f>= value _f1) ; find largest power of 10 <= value
+ (progn ; value >= 1, power is positive
+ (while (f<= (setq temp (f* pow10 highest-power-of-10)) value)
+ (setq pow10 temp
+ power (+ power decimal-digits)))
+ (while (f<= (setq temp (f* pow10 _f10)) value)
+ (setq pow10 temp
+ power (1+ power))))
+ (progn ; value < 1, power is negative
+ (while (f> (setq temp (f/ pow10 highest-power-of-10)) value)
+ (setq pow10 temp
+ power (- power decimal-digits)))
+ (while (f> pow10 value)
+ (setq pow10 (f/ pow10 _f10)
+ power (1- power)))))
+ ; get value in range 100000 to 999999
+ (setq value (f* (f/ value pow10) all-decimal-digs-minval)
+ result (ftrunc value))
+ (let (int)
+ (if (f> (f- value result) _f1/2) ; round up if remainder > 0.5
+ (setq int (1+ (fint result)))
+ (setq int (fint result)))
+ (setq str (int-to-string int))
+ (if (>= int 1000000)
+ (setq power (1+ power))))
+
+ (if sci ; scientific notation
+ (setq str (concat (substring str 0 1) "." (substring str 1)
+ "E" (int-to-string power)))
+
+ ; regular decimal string
+ (cond ((>= power (1- decimal-digits))
+ ; large power, append zeroes
+ (let ((zeroes (- power decimal-digits)))
+ (while (natnump zeroes)
+ (setq str (concat str "0")
+ zeroes (1- zeroes)))))
+
+ ; negative power, prepend decimal
+ ((< power 0) ; point and zeroes
+ (let ((zeroes (- (- power) 2)))
+ (while (natnump zeroes)
+ (setq str (concat "0" str)
+ zeroes (1- zeroes)))
+ (setq str (concat "0." str))))
+
+ (t ; in range, insert decimal point
+ (setq str (concat
+ (substring str 0 (1+ power))
+ "."
+ (substring str (1+ power)))))))
+
+ (if sign ; if negative, prepend minus sign
+ (concat "-" str)
+ str))))
+
+
+;; string to float conversion.
+;; accepts scientific notation, but ignores anything after the first two
+;; digits of the exponent.
+(defun string-to-float (str)
+ "Convert the string to a floating point number.
+Accepts a decimal string in scientific notation,
+with exponent preceded by either E or e.
+Only the 6 most significant digits of the integer and fractional parts
+are used; only the first two digits of the exponent are used.
+Negative signs preceding both the decimal number and the exponent
+are recognized."
+
+ (if (string-match floating-point-regexp str 0)
+ (let (power)
+ (f*
+ ; calculate the mantissa
+ (let* ((int-subst (extract-match str 2))
+ (fract-subst (extract-match str 4))
+ (digit-string (concat int-subst fract-subst))
+ (mant-sign (equal (extract-match str 1) "-"))
+ (leading-0s 0) (round-up nil))
+
+ ; get rid of leading 0's
+ (setq power (- (length int-subst) decimal-digits))
+ (while (and (< leading-0s (length digit-string))
+ (= (aref digit-string leading-0s) ?0))
+ (setq leading-0s (1+ leading-0s)))
+ (setq power (- power leading-0s)
+ digit-string (substring digit-string leading-0s))
+
+ ; if more than 6 digits, round off
+ (if (> (length digit-string) decimal-digits)
+ (setq round-up (>= (aref digit-string decimal-digits) ?5)
+ digit-string (substring digit-string 0 decimal-digits))
+ (setq power (+ power (- decimal-digits (length digit-string)))))
+
+ ; round up and add minus sign, if necessary
+ (f (* (+ (string-to-int digit-string)
+ (if round-up 1 0))
+ (if mant-sign -1 1))))
+
+ ; calculate the exponent (power of ten)
+ (let* ((expt-subst (extract-match str 9))
+ (expt-sign (equal (extract-match str 8) "-"))
+ (expt 0) (chunks 0) (tens 0) (exponent _f1)
+ (func 'f*))
+
+ (setq expt (+ (* (string-to-int
+ (substring expt-subst 0
+ (min expt-digits (length expt-subst))))
+ (if expt-sign -1 1))
+ power))
+ (if (< expt 0) ; if power of 10 negative
+ (setq expt (- expt) ; take abs val of exponent
+ func 'f/)) ; and set up to divide, not multiply
+
+ (setq chunks (/ expt decimal-digits)
+ tens (% expt decimal-digits))
+ ; divide or multiply by "chunks" of 10**6
+ (while (> chunks 0)
+ (setq exponent (funcall func exponent highest-power-of-10)
+ chunks (1- chunks)))
+ ; divide or multiply by remaining power of ten
+ (funcall func exponent (aref powers-of-10 tens)))))
+
+ _f0)) ; if invalid, return 0
+
+
--- /dev/null
+;;; Fortran mode for GNU Emacs (beta test version 1.21, Oct. 1, 1985)
+;;; Copyright (c) 1986 Free Software Foundation, Inc.
+;;; Written by Michael D. Prange (prange@erl.mit.edu)
+
+;; 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.
+
+;;; Author acknowledges help from Stephen Gildea <gildea@erl.mit.edu>
+
+;;; Bugs to bug-fortran-mode@erl.mit.edu.
+
+(defvar fortran-do-indent 3
+ "*Extra indentation applied to `do' blocks.")
+
+(defvar fortran-if-indent 3
+ "*Extra indentation applied to `if' blocks.")
+
+(defvar fortran-continuation-indent 5
+ "*Extra indentation applied to `continuation' lines.")
+
+(defvar fortran-comment-indent-style 'fixed
+ "*nil forces comment lines not to be touched,
+'fixed produces fixed comment indentation to comment-column,
+and 'relative indents to current fortran indentation plus comment-column.")
+
+(defvar fortran-comment-line-column 6
+ "*Indentation for text in comment lines.")
+
+(defvar comment-line-start nil
+ "*Delimiter inserted to start new full-line comment.")
+
+(defvar comment-line-start-skip nil
+ "*Regexp to match the start of a full-line comment.")
+
+(defvar fortran-minimum-statement-indent 6
+ "*Minimum indentation for fortran statements.")
+
+;; Note that this is documented in the v18 manuals as being a string
+;; of length one rather than a single character.
+;; The code in this file accepts either format for compatibility.
+(defvar fortran-comment-indent-char ?
+ "*Character to be inserted for Fortran comment indentation.
+Normally a space.")
+
+(defvar fortran-line-number-indent 1
+ "*Maximum indentation for Fortran line numbers.
+5 means right-justify them within their five-column field.")
+
+(defvar fortran-check-all-num-for-matching-do nil
+ "*Non-nil causes all numbered lines to be treated as possible do-loop ends.")
+
+(defvar fortran-continuation-char ?$
+ "*Character which is inserted in column 5 by \\[fortran-split-line]
+to begin a continuation line. Normally $.")
+
+(defvar fortran-comment-region "c$$$"
+ "*String inserted by \\[fortran-comment-region] at start of each line in region.")
+
+(defvar fortran-electric-line-number t
+ "*Non-nil causes line number digits to be moved to the correct column as typed.")
+
+(defvar fortran-startup-message t
+ "*Non-nil displays a startup message when fortran-mode is first called.")
+
+(defvar fortran-column-ruler
+ (concat "0 4 6 10 20 30 40 50 60 70\n"
+ "[ ]|{ | | | | | | | | | | | | |}\n")
+ "*String displayed above current line by \\[fortran-column-ruler].")
+
+(defconst fortran-mode-version "1.21")
+
+(defvar fortran-mode-syntax-table nil
+ "Syntax table in use in fortran-mode buffers.")
+
+(if fortran-mode-syntax-table
+ ()
+ (setq fortran-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\; "w" fortran-mode-syntax-table)
+ (modify-syntax-entry ?+ "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?- "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?* "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?/ "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\\ "/" fortran-mode-syntax-table)
+ (modify-syntax-entry ?. "w" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" fortran-mode-syntax-table))
+
+(defvar fortran-mode-map ()
+ "Keymap used in fortran mode.")
+
+(if fortran-mode-map
+ ()
+ (setq fortran-mode-map (make-sparse-keymap))
+ (define-key fortran-mode-map ";" 'fortran-abbrev-start)
+ (define-key fortran-mode-map "\C-c;" 'fortran-comment-region)
+ (define-key fortran-mode-map "\e\C-a" 'beginning-of-fortran-subprogram)
+ (define-key fortran-mode-map "\e\C-e" 'end-of-fortran-subprogram)
+ (define-key fortran-mode-map "\e;" 'fortran-indent-comment)
+ (define-key fortran-mode-map "\e\C-h" 'mark-fortran-subprogram)
+ (define-key fortran-mode-map "\e\n" 'fortran-split-line)
+ (define-key fortran-mode-map "\e\C-q" 'fortran-indent-subprogram)
+ (define-key fortran-mode-map "\C-c\C-w" 'fortran-window-create)
+ (define-key fortran-mode-map "\C-c\C-r" 'fortran-column-ruler)
+ (define-key fortran-mode-map "\C-c\C-p" 'fortran-previous-statement)
+ (define-key fortran-mode-map "\C-c\C-n" 'fortran-next-statement)
+ (define-key fortran-mode-map "\t" 'fortran-indent-line)
+ (define-key fortran-mode-map "0" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "1" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "2" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "3" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "4" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "5" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "6" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "7" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "8" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "9" 'fortran-electric-line-number))
+\f
+(defvar fortran-mode-abbrev-table nil)
+(if fortran-mode-abbrev-table
+ ()
+ (define-abbrev-table 'fortran-mode-abbrev-table ())
+ (let ((abbrevs-changed nil))
+ (define-abbrev fortran-mode-abbrev-table ";b" "byte" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ch" "character" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cl" "close" nil)
+ (define-abbrev fortran-mode-abbrev-table ";c" "continue" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cm" "common" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cx" "complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";di" "dimension" nil)
+ (define-abbrev fortran-mode-abbrev-table ";do" "double" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dc" "double complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dp" "double precision" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dw" "do while" nil)
+ (define-abbrev fortran-mode-abbrev-table ";e" "else" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ed" "enddo" nil)
+ (define-abbrev fortran-mode-abbrev-table ";el" "elseif" nil)
+ (define-abbrev fortran-mode-abbrev-table ";en" "endif" nil)
+ (define-abbrev fortran-mode-abbrev-table ";eq" "equivalence" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ex" "external" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ey" "entry" nil)
+ (define-abbrev fortran-mode-abbrev-table ";f" "format" nil)
+ (define-abbrev fortran-mode-abbrev-table ";fu" "function" nil)
+ (define-abbrev fortran-mode-abbrev-table ";g" "goto" nil)
+ (define-abbrev fortran-mode-abbrev-table ";im" "implicit" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ib" "implicit byte" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ic" "implicit complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ich" "implicit character" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ii" "implicit integer" nil)
+ (define-abbrev fortran-mode-abbrev-table ";il" "implicit logical" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ir" "implicit real" nil)
+ (define-abbrev fortran-mode-abbrev-table ";inc" "include" nil)
+ (define-abbrev fortran-mode-abbrev-table ";in" "integer" nil)
+ (define-abbrev fortran-mode-abbrev-table ";intr" "intrinsic" nil)
+ (define-abbrev fortran-mode-abbrev-table ";l" "logical" nil)
+ (define-abbrev fortran-mode-abbrev-table ";op" "open" nil)
+ (define-abbrev fortran-mode-abbrev-table ";pa" "parameter" nil)
+ (define-abbrev fortran-mode-abbrev-table ";pr" "program" nil)
+ (define-abbrev fortran-mode-abbrev-table ";p" "print" nil)
+ (define-abbrev fortran-mode-abbrev-table ";re" "real" nil)
+ (define-abbrev fortran-mode-abbrev-table ";r" "read" nil)
+ (define-abbrev fortran-mode-abbrev-table ";rt" "return" nil)
+ (define-abbrev fortran-mode-abbrev-table ";rw" "rewind" nil)
+ (define-abbrev fortran-mode-abbrev-table ";s" "stop" nil)
+ (define-abbrev fortran-mode-abbrev-table ";su" "subroutine" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ty" "type" nil)
+ (define-abbrev fortran-mode-abbrev-table ";w" "write" nil)))
+\f
+(defun fortran-mode ()
+ "Major mode for editing fortran code.
+Tab indents the current fortran line correctly.
+`do' statements must not share a common `continue'.
+
+Type `;?' or `;\\[help-command]' to display a list of built-in abbrevs for Fortran keywords.
+
+Variables controlling indentation style and extra features:
+
+ comment-start
+ Normally nil in Fortran mode. If you want to use comments
+ starting with `!', set this to the string \"!\".
+ fortran-do-indent
+ Extra indentation within do blocks. (default 3)
+ fortran-if-indent
+ Extra indentation within if blocks. (default 3)
+ fortran-continuation-indent
+ Extra indentation appled to continuation statements. (default 5)
+ fortran-comment-line-column
+ Amount of indentation for text within full-line comments. (default 6)
+ fortran-comment-indent-style
+ nil means don't change indentation of text in full-line comments,
+ fixed means indent that text at column fortran-comment-line-column
+ relative means indent at fortran-comment-line-column beyond the
+ indentation for a line of code.
+ Default value is fixed.
+ fortran-comment-indent-char
+ Character to be inserted instead of space for full-line comment
+ indentation. (default is a space)
+ fortran-minimum-statement-indent
+ Minimum indentation for fortran statements. (default 6)
+ fortran-line-number-indent
+ Maximum indentation for line numbers. A line number will get
+ less than this much indentation if necessary to avoid reaching
+ column 5. (default 1)
+ fortran-check-all-num-for-matching-do
+ Non-nil causes all numbered lines to be treated as possible 'continue'
+ statements. (default nil)
+ fortran-continuation-char
+ character to be inserted in column 5 of a continuation line.
+ (default $)
+ fortran-comment-region
+ String inserted by \\[fortran-comment-region] at start of each line in
+ region. (default \"c$$$\")
+ fortran-electric-line-number
+ Non-nil causes line number digits to be moved to the correct column
+ as typed. (default t)
+ fortran-startup-message
+ Set to nil to inhibit message first time fortran-mode is used.
+
+Turning on Fortran mode calls the value of the variable fortran-mode-hook
+with no args, if that value is non-nil.
+\\{fortran-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (if fortran-startup-message
+ (message "Emacs Fortran mode version %s. Bugs to bug-fortran-mode@erl.mit.edu" fortran-mode-version))
+ (setq fortran-startup-message nil)
+ (setq local-abbrev-table fortran-mode-abbrev-table)
+ (set-syntax-table fortran-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'fortran-indent-line)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'fortran-comment-hook)
+ (make-local-variable 'comment-line-start-skip)
+ (setq comment-line-start-skip "^[Cc*][^ \t\n]*[ \t]*") ;[^ \t\n]* handles comment strings such as c$$$
+ (make-local-variable 'comment-line-start)
+ (setq comment-line-start "c")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "![ \t]*")
+ (make-local-variable 'comment-start)
+ (setq comment-start nil)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'abbrev-all-caps)
+ (setq abbrev-all-caps t)
+ (make-local-variable 'indent-tabs-mode)
+ (setq indent-tabs-mode nil)
+ (use-local-map fortran-mode-map)
+ (setq mode-name "Fortran")
+ (setq major-mode 'fortran-mode)
+ (run-hooks 'fortran-mode-hook))
+\f
+(defun fortran-comment-hook ()
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (+ 1 (current-column))
+ comment-column)))
+
+(defun fortran-indent-comment ()
+ "Align or create comment on current line.
+Existing comments of all types are recognized and aligned.
+If the line has no comment, a side-by-side comment is inserted and aligned
+if the value of comment-start is not nil.
+Otherwise, a separate-line comment is inserted, on this line
+or on a new line inserted before this line if this line is not blank."
+ (interactive)
+ (beginning-of-line)
+ ;; Recognize existing comments of either kind.
+ (cond ((looking-at comment-line-start-skip)
+ (fortran-indent-line))
+ ((re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) t)
+ (indent-for-comment))
+ ;; No existing comment.
+ ;; If side-by-side comments are defined, insert one,
+ ;; unless line is now blank.
+ ((and comment-start (not (looking-at "^[ \t]*$")))
+ (end-of-line)
+ (delete-horizontal-space)
+ (indent-to (fortran-comment-hook))
+ (insert comment-start))
+ ;; Else insert separate-line comment, making a new line if nec.
+ (t
+ (if (looking-at "^[ \t]*$")
+ (delete-horizontal-space)
+ (beginning-of-line)
+ (insert "\n")
+ (forward-char -1))
+ (insert comment-line-start)
+ (insert-char (if (stringp fortran-comment-indent-char)
+ (aref fortran-comment-indent-char 0)
+ fortran-comment-indent-char)
+ (- (calculate-fortran-indent) (current-column))))))
+
+(defun fortran-comment-region (beg-region end-region arg)
+ "Comments every line in the region.
+Puts fortran-comment-region at the beginning of every line in the region.
+BEG-REGION and END-REGION are args which specify the region boundaries.
+With non-nil ARG, uncomments the region."
+ (interactive "*r\nP")
+ (let ((end-region-mark (make-marker)) (save-point (point-marker)))
+ (set-marker end-region-mark end-region)
+ (goto-char beg-region)
+ (beginning-of-line)
+ (if (not arg) ;comment the region
+ (progn (insert fortran-comment-region)
+ (while (and (= (forward-line 1) 0)
+ (< (point) end-region-mark))
+ (insert fortran-comment-region)))
+ (let ((com (regexp-quote fortran-comment-region))) ;uncomment the region
+ (if (looking-at com)
+ (delete-region (point) (match-end 0)))
+ (while (and (= (forward-line 1) 0)
+ (< (point) end-region-mark))
+ (if (looking-at com)
+ (delete-region (point) (match-end 0))))))
+ (goto-char save-point)
+ (set-marker end-region-mark nil)
+ (set-marker save-point nil)))
+\f
+(defun fortran-abbrev-start ()
+ "Typing \";\\[help-command]\" or \";?\" lists all the fortran abbrevs.
+Any other key combination is executed normally." ;\\[help-command] is just a way to print the value of the variable help-char.
+ (interactive)
+ (let (c)
+ (insert last-command-char)
+ (if (or (= (setq c (read-char)) ??) ;insert char if not equal to `?'
+ (= c help-char))
+ (fortran-abbrev-help)
+ (setq unread-command-char c))))
+
+(defun fortran-abbrev-help ()
+ "List the currently defined abbrevs in Fortran mode."
+ (interactive)
+ (message "Listing abbrev table...")
+ (require 'abbrevlist)
+ (list-one-abbrev-table fortran-mode-abbrev-table "*Help*")
+ (message "Listing abbrev table...done"))
+
+(defun fortran-column-ruler ()
+ "Inserts a column ruler momentarily above current line, till next keystroke.
+The ruler is defined by the value of fortran-column-ruler.
+The key typed is executed unless it is SPC."
+ (interactive)
+ (momentary-string-display
+ fortran-column-ruler (save-excursion (beginning-of-line) (point))
+ nil "Type SPC or any command to erase ruler."))
+
+(defun fortran-window-create ()
+ "Makes the window 72 columns wide."
+ (interactive)
+ (let ((window-min-width 2))
+ (split-window-horizontally 73))
+ (other-window 1)
+ (switch-to-buffer " fortran-window-extra" t)
+ (select-window (previous-window)))
+
+(defun fortran-split-line ()
+ "Break line at point and insert continuation marker and alignment."
+ (interactive)
+ (delete-horizontal-space)
+ (if (save-excursion (beginning-of-line) (looking-at comment-line-start-skip))
+ (insert "\n" comment-line-start " ")
+ (insert "\n " fortran-continuation-char))
+ (fortran-indent-line))
+
+(defun delete-horizontal-regexp (chars)
+ "Delete all characters in CHARS around point.
+CHARS is like the inside of a [...] in a regular expression
+except that ] is never special and \ quotes ^, - or \."
+ (interactive "*s")
+ (skip-chars-backward chars)
+ (delete-region (point) (progn (skip-chars-forward chars) (point))))
+
+(defun fortran-electric-line-number (arg)
+ "Self insert, but if part of a Fortran line number indent it automatically.
+Auto-indent does not happen if a numeric arg is used."
+ (interactive "P")
+ (if (or arg (not fortran-electric-line-number))
+ (self-insert-command arg)
+ (if (or (save-excursion (re-search-backward "[^ \t0-9]"
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)) ;not a line number
+ (looking-at "[0-9]")) ;within a line number
+ (insert last-command-char)
+ (skip-chars-backward " \t")
+ (insert last-command-char)
+ (fortran-indent-line))))
+\f
+(defun beginning-of-fortran-subprogram ()
+ "Moves point to the beginning of the current fortran subprogram."
+ (interactive)
+ (let ((case-fold-search t))
+ (beginning-of-line -1)
+ (re-search-backward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move)
+ (if (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]")
+ (forward-line 1))))
+
+(defun end-of-fortran-subprogram ()
+ "Moves point to the end of the current fortran subprogram."
+ (interactive)
+ (let ((case-fold-search t))
+ (beginning-of-line 2)
+ (re-search-forward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line 1)))
+
+(defun mark-fortran-subprogram ()
+ "Put mark at end of fortran subprogram, point at beginning.
+The marks are pushed."
+ (interactive)
+ (end-of-fortran-subprogram)
+ (push-mark (point))
+ (beginning-of-fortran-subprogram))
+
+(defun fortran-previous-statement ()
+ "Moves point to beginning of the previous fortran statement.
+Returns 'first-statement if that statement is the first
+non-comment Fortran statement in the file, and nil otherwise."
+ (interactive)
+ (let (not-first-statement continue-test)
+ (beginning-of-line)
+ (setq continue-test
+ (or (looking-at
+ (concat "[ \t]*" (regexp-quote (char-to-string
+ fortran-continuation-char))))
+ (looking-at " [^ 0\n]")))
+ (while (and (setq not-first-statement (= (forward-line -1) 0))
+ (or (looking-at comment-line-start-skip)
+ (looking-at "[ \t]*$")
+ (looking-at " [^ 0\n]")
+ (looking-at (concat "[ \t]*" comment-start-skip)))))
+ (cond ((and continue-test
+ (not not-first-statement))
+ (message "Incomplete continuation statement."))
+ (continue-test
+ (fortran-previous-statement))
+ ((not not-first-statement)
+ 'first-statement))))
+
+(defun fortran-next-statement ()
+ "Moves point to beginning of the next fortran statement.
+ Returns 'last-statement if that statement is the last
+ non-comment Fortran statement in the file, and nil otherwise."
+ (interactive)
+ (let (not-last-statement)
+ (beginning-of-line)
+ (while (and (setq not-last-statement (= (forward-line 1) 0))
+ (or (looking-at comment-line-start-skip)
+ (looking-at "[ \t]*$")
+ (looking-at " [^ 0\n]")
+ (looking-at (concat "[ \t]*" comment-start-skip)))))
+ (if (not not-last-statement)
+ 'last-statement)))
+\f
+(defun fortran-indent-line ()
+ "Indents current fortran line based on its contents and on previous lines."
+ (interactive)
+ (let ((cfi (calculate-fortran-indent)))
+ (save-excursion
+ (beginning-of-line)
+ (if (or (not (= cfi (fortran-current-line-indentation)))
+ (and (re-search-forward "^[ \t]*[0-9]+" (+ (point) 4) t)
+ (not (fortran-line-number-indented-correctly-p))))
+ (fortran-indent-to-column cfi)
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) 'move)
+ (fortran-indent-comment))))
+ ;; Never leave point in left margin.
+ (if (< (current-column) cfi)
+ (move-to-column cfi))))
+
+(defun fortran-indent-subprogram ()
+ "Properly indents the Fortran subprogram which contains point."
+ (interactive)
+ (save-excursion
+ (mark-fortran-subprogram)
+ (message "Indenting subprogram...")
+ (indent-region (point) (mark) nil))
+ (message "Indenting subprogram...done."))
+
+(defun calculate-fortran-indent ()
+ "Calculates the fortran indent column based on previous lines."
+ (let (icol first-statement (case-fold-search t))
+ (save-excursion
+ (setq first-statement (fortran-previous-statement))
+ (if first-statement
+ (setq icol fortran-minimum-statement-indent)
+ (progn
+ (if (= (point) (point-min))
+ (setq icol fortran-minimum-statement-indent)
+ (setq icol (fortran-current-line-indentation)))
+ (skip-chars-forward " \t0-9")
+ (cond ((looking-at "if[ \t]*(")
+ (if (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]")
+ (let (then-test) ;multi-line if-then
+ (while (and (= (forward-line 1) 0) ;search forward for then
+ (looking-at " [^ 0]")
+ (not (setq then-test (looking-at ".*then\\b[ \t]*[^ \t(=a-z0-9]")))))
+ then-test))
+ (setq icol (+ icol fortran-if-indent))))
+ ((looking-at "\\(else\\|elseif\\)\\b")
+ (setq icol (+ icol fortran-if-indent)))
+ ((looking-at "do\\b")
+ (setq icol (+ icol fortran-do-indent)))))))
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at "[ \t]*$"))
+ ((looking-at comment-line-start-skip)
+ (cond ((eq fortran-comment-indent-style 'relative)
+ (setq icol (+ icol fortran-comment-line-column)))
+ ((eq fortran-comment-indent-style 'fixed)
+ (setq icol fortran-comment-line-column))))
+ ((or (looking-at (concat "[ \t]*"
+ (regexp-quote (char-to-string fortran-continuation-char))))
+ (looking-at " [^ 0\n]"))
+ (setq icol (+ icol fortran-continuation-indent)))
+ (first-statement)
+ ((and fortran-check-all-num-for-matching-do
+ (looking-at "[ \t]*[0-9]+")
+ (fortran-check-for-matching-do))
+ (setq icol (- icol fortran-do-indent)))
+ (t
+ (skip-chars-forward " \t0-9")
+ (cond ((looking-at "end[ \t]*if\\b")
+ (setq icol (- icol fortran-if-indent)))
+ ((looking-at "\\(else\\|elseif\\)\\b")
+ (setq icol (- icol fortran-if-indent)))
+ ((and (looking-at "continue\\b")
+ (fortran-check-for-matching-do))
+ (setq icol (- icol fortran-do-indent)))
+ ((looking-at "end[ \t]*do\\b")
+ (setq icol (- icol fortran-do-indent)))
+ ((and (looking-at "end\\b[ \t]*[^ \t=(a-z]")
+ (not (= icol fortran-minimum-statement-indent)))
+ (message "Warning: `end' not in column %d. Probably an unclosed block." fortran-minimum-statement-indent))))))
+ (max fortran-minimum-statement-indent icol)))
+\f
+(defun fortran-current-line-indentation ()
+ "Indentation of current line, ignoring Fortran line number or continuation.
+This is the column position of the first non-whitespace character
+aside from the line number and/or column 5 line-continuation character.
+For comment lines, returns indentation of the first
+non-indentation text within the comment."
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at comment-line-start-skip)
+ (goto-char (match-end 0))
+ (skip-chars-forward
+ (if (stringp fortran-comment-indent-char)
+ fortran-comment-indent-char
+ (char-to-string fortran-comment-indent-char))))
+ ((looking-at " [^ 0\n]")
+ (goto-char (match-end 0)))
+ (t
+ ;; Move past line number.
+ (move-to-column 5)))
+ ;; Move past whitespace.
+ (skip-chars-forward " \t")
+ (current-column)))
+
+(defun fortran-indent-to-column (col)
+ "Indents current line with spaces to column COL.
+notes: 1) A non-zero/non-blank character in column 5 indicates a continuation
+ line, and this continuation character is retained on indentation;
+ 2) If fortran-continuation-char is the first non-whitespace character,
+ this is a continuation line;
+ 3) A non-continuation line which has a number as the first
+ non-whitespace character is a numbered line."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at comment-line-start-skip)
+ (if fortran-comment-indent-style
+ (let ((char (if (stringp fortran-comment-indent-char)
+ (aref fortran-comment-indent-char 0)
+ fortran-comment-indent-char)))
+ (goto-char (match-end 0))
+ (delete-horizontal-regexp (concat " \t" (char-to-string char)))
+ (insert-char char (- col (current-column)))))
+ (if (looking-at " [^ 0\n]")
+ (forward-char 6)
+ (delete-horizontal-space)
+ ;; Put line number in columns 0-4
+ ;; or put continuation character in column 5.
+ (cond ((eobp))
+ ((= (following-char) fortran-continuation-char)
+ (indent-to 5)
+ (forward-char 1))
+ ((looking-at "[0-9]+")
+ (let ((extra-space (- 5 (- (match-end 0) (point)))))
+ (if (< extra-space 0)
+ (message "Warning: line number exceeds 5-digit limit.")
+ (indent-to (min fortran-line-number-indent extra-space))))
+ (skip-chars-forward "0-9"))))
+ ;; Point is now after any continuation character or line number.
+ ;; Put body of statement where specified.
+ (delete-horizontal-space)
+ (indent-to col)
+ ;; Indent any comment following code on the same line.
+ (if (re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) t)
+ (progn (goto-char (match-beginning 0))
+ (if (not (= (current-column) (fortran-comment-hook)))
+ (progn (delete-horizontal-space)
+ (indent-to (fortran-comment-hook)))))))))
+
+(defun fortran-line-number-indented-correctly-p ()
+ "Return t if current line's line number is correctly indente.
+Do not call if there is no line number."
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (and (<= (current-column) fortran-line-number-indent)
+ (or (= (current-column) fortran-line-number-indent)
+ (progn (skip-chars-forward "0-9")
+ (= (current-column) 5))))))
+
+(defun fortran-check-for-matching-do ()
+ "When called from a numbered statement, returns t
+ if matching 'do' is found, and nil otherwise."
+ (let (charnum
+ (case-fold-search t))
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "[ \t]*[0-9]+")
+ (progn
+ (skip-chars-forward " \t")
+ (skip-chars-forward "0") ;skip past leading zeros
+ (setq charnum (buffer-substring (point)
+ (progn (skip-chars-forward "0-9")
+ (point))))
+ (beginning-of-line)
+ (and (re-search-backward
+ (concat "\\(^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]\\)\\|\\(^[ \t0-9]*do[ \t]*0*"
+ charnum "\\b\\)\\|\\(^[ \t]*0*" charnum "\\b\\)")
+ nil t)
+ (looking-at (concat "^[ \t0-9]*do[ \t]*0*" charnum))))))))
+
+
--- /dev/null
+;; File input and output over Internet using FTP
+;; Copyright (C) 1987 Free Software Foundation, Inc.
+;; Author mly@prep.ai.mit.edu.
+
+;; 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.
+
+
+;; you can turn this off by doing
+;; (setq ftp-password-alist 'compulsory-urinalysis)
+(defvar ftp-password-alist () "Security sucks")
+
+(defun read-ftp-user-password (host user new)
+ (let (tem)
+ (if (and (not new)
+ (listp ftp-password-alist)
+ (setq tem (cdr (assoc host ftp-password-alist)))
+ (or (null user)
+ (string= user (car tem))))
+ tem
+ (or user
+ (progn
+ (setq tem (or (and (listp ftp-password-alist)
+ (car (cdr (assoc host ftp-password-alist))))
+ (user-login-name)))
+ (setq user (read-string (format
+ "User-name for %s (default \"%s\"): "
+ host tem)))
+ (if (equal user "") (setq user tem))))
+ (setq tem (cons user
+ ;; If you want to use some non-echoing string-reader,
+ ;; feel free to write it yourself. I don't care enough.
+ (read-string (format "Password for %s@%s: " user host)
+ (if (not (listp ftp-password-alist))
+ ""
+ (or (cdr (cdr (assoc host ftp-password-alist)))
+ (let ((l ftp-password-alist))
+ (catch 'foo
+ (while l
+ (if (string= (car (cdr (car l))) user)
+ (throw 'foo (cdr (cdr (car l))))
+ (setq l (cdr l))))
+ nil))
+ "")))))
+ (message "")
+ (if (and (listp ftp-password-alist)
+ (not (string= (cdr tem) "")))
+ (setq ftp-password-alist (cons (cons host tem)
+ ftp-password-alist)))
+ tem)))
+
+(defun ftp-read-file-name (prompt)
+ (let ((s ""))
+ (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s))
+ (setq s (read-string prompt s)))
+ (list (substring s (match-beginning 1) (match-end 1))
+ (substring s (match-beginning 2) (match-end 2)))))
+
+
+(defun ftp-find-file (host file &optional user password)
+ "FTP to HOST to get FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ (interactive
+ (append (ftp-read-file-name "FTP get host:file: ")
+ (list nil (not (null current-prefix-arg)))))
+ (ftp-find-file-or-directory host file t user password))
+
+(defun ftp-list-directory (host file &optional user password)
+ "FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ (interactive
+ (append (ftp-read-file-name "FTP get host:directory: ")
+ (list nil (not (null current-prefix-arg)))))
+ (ftp-find-file-or-directory host file nil user password))
+
+(defun ftp-find-file-or-directory (host file filep &optional user password)
+ "FTP to HOST to get FILE. Third arg is t for file, nil for directory.
+Log in as USER with PASSWORD. If USER is nil or PASSWORD is nil or t,
+we prompt for the user name and password."
+ (or (and user password (not (eq password t)))
+ (progn (setq user (read-ftp-user-password host user (eq password t))
+ password (cdr user)
+ user (car user))))
+ (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*"
+ (if filep "" "-directory")
+ host file))))
+ (set-buffer buffer)
+ (let ((process (ftp-setup-buffer host file))
+ (case-fold-search nil))
+ (let ((win nil))
+ (unwind-protect
+ (if (setq win (ftp-login process host user password))
+ (message "Logged in")
+ (error "Ftp login lost"))
+ (or win (delete-process process))))
+ (message "Opening %s %s:%s..." (if filep "file" "directory")
+ host file)
+ (if (ftp-command process
+ (format "%s \"%s\" -\nquit\n" (if filep "get" "dir")
+ file)
+ "\\(150\\|125\\).*\n"
+ "200.*\n")
+ (progn (forward-line 1)
+ (let ((buffer-read-only nil))
+ (delete-region (point-min) (point)))
+ (message "Retrieving %s:%s in background. Bye!" host file)
+ (set-process-sentinel process
+ 'ftp-asynchronous-input-sentinel)
+ process)
+ (switch-to-buffer buffer)
+ (let ((buffer-read-only nil))
+ (insert-before-markers "<<<Ftp lost>>>"))
+ (delete-process process)
+ (error "Ftp %s:%s lost" host file)))))
+
+\f
+(defun ftp-write-file (host file &optional user password)
+ "FTP to HOST to write FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with colon
+separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ (interactive
+ (append (ftp-read-file-name "FTP write host:file: ")
+ (list nil (not (null current-prefix-arg)))))
+ (or (and user password (not (eq password t)))
+ (progn (setq user (read-ftp-user-password host user (eq password t))
+ password (cdr user)
+ user (car user))))
+ (let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file)))
+ (tmp (make-temp-name "/tmp/emacsftp")))
+ (write-region (point-min) (point-max) tmp)
+ (set-buffer buffer)
+ (make-local-variable 'ftp-temp-file-name)
+ (setq ftp-temp-file-name tmp)
+ (let ((process (ftp-setup-buffer host file))
+ (case-fold-search nil))
+ (let ((win nil))
+ (unwind-protect
+ (if (setq win (ftp-login process host user password))
+ (message "Logged in")
+ (error "Ftp login lost"))
+ (or win (delete-process process))))
+ (message "Opening file %s:%s..." host file)
+ (if (ftp-command process
+ (format "send \"%s\" \"%s\"\nquit\n" tmp file)
+ "\\(150\\|125\\).*\n"
+ "200.*\n")
+ (progn (forward-line 1)
+ (let ((buffer-read-only nil))
+ (delete-region (point-min) (point)))
+ (message "Saving %s:%s in background. Bye!" host file)
+ (set-process-sentinel process
+ 'ftp-asynchronous-output-sentinel)
+ process)
+ (switch-to-buffer buffer)
+ (let ((buffer-read-only nil))
+ (insert-before-markers "<<<Ftp lost>>>"))
+ (delete-process process)
+ (error "Ftp write %s:%s lost" host file)))))
+
+\f
+(defun ftp-setup-buffer (host file)
+ (fundamental-mode)
+ (and (get-buffer-process (current-buffer))
+ (progn (discard-input)
+ (if (y-or-n-p (format "Kill process \"%s\" in %s? "
+ (process-name (get-buffer-process
+ (current-buffer)))
+ (buffer-name (current-buffer))))
+ (while (get-buffer-process (current-buffer))
+ (kill-process (get-buffer-process (current-buffer))))
+ (error "Foo"))))
+ ;(buffer-flush-undo (current-buffer))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (make-local-variable 'ftp-host)
+ (setq ftp-host host)
+ (make-local-variable 'ftp-file)
+ (setq ftp-file file)
+ (setq buffer-read-only t)
+ (start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g"))
+
+
+(defun ftp-login (process host user password)
+ (message "FTP logging in as %s@%s..." user host)
+ (if (ftp-command process
+ (format "open %s\nuser %s %s\n" host user password)
+ "230.*\n"
+ "\\(Connected to \\|220\\|331\\).*\n")
+ t
+ (switch-to-buffer (process-buffer process))
+ (delete-process process)
+ (if (listp ftp-password-alist)
+ (setq ftp-password-alist (delq (assoc host ftp-password-alist)
+ ftp-password-alist)))
+ nil))
+
+(defun ftp-command (process command win ignore)
+ (process-send-string process command)
+ (let ((p 1)
+ (case-fold-search t))
+ (while (numberp p)
+ (cond ;((not (bolp)))
+ ((looking-at win)
+ (goto-char (point-max))
+ (setq p t))
+ ((looking-at "^ftp> \\|^\n")
+ (goto-char (match-end 0)))
+ ((looking-at ignore)
+ ;; Ignore status messages whose codes indicate no problem.
+ (forward-line 1))
+ ((not (search-forward "\n" nil t))
+ ;; the way asynchronous process-output fucks with (point)
+ ;; is really really disgusting.
+ (setq p (point))
+ (condition-case ()
+ (accept-process-output process)
+ (error nil))
+ (goto-char p))
+ ((looking-at "^[a-z]")
+ ;; Ignore any lines that don't have error codes.
+ (forward-line 1))
+ (t
+ (setq p nil))))
+ p))
+
+
+(defun ftp-asynchronous-input-sentinel (process msg)
+ (ftp-sentinel process msg t t))
+(defun ftp-synchronous-input-sentinel (process msg)
+ (ftp-sentinel process msg nil t))
+(defun ftp-asynchronous-output-sentinel (process msg)
+ (ftp-sentinel process msg t nil))
+(defun ftp-synchronous-output-sentinel (process msg)
+ (ftp-sentinel process msg nil nil))
+
+(defun ftp-sentinel (process msg asynchronous input)
+ (cond ((null (buffer-name (process-buffer process)))
+ ;; deleted buffer
+ (set-process-buffer process nil))
+ ((and (eq (process-status process) 'exit)
+ (= (process-exit-status process) 0))
+ (save-excursion
+ (set-buffer (process-buffer process))
+ (let (msg
+ (r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$")))
+ (goto-char (point-max))
+ (search-backward "226 ")
+ (if (looking-at r)
+ (search-backward "226 "))
+ (let ((p (point)))
+ (setq msg (concat (format "ftp %s %s:%s done"
+ (if input "read" "write")
+ ftp-host ftp-file)
+ (if (re-search-forward r nil t)
+ (concat ": " (buffer-substring
+ (match-beginning 0)
+ (match-end 0)))
+ "")))
+ (let ((buffer-read-only nil))
+ (delete-region p (point-max)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*ftp log*"))
+ (let ((buffer-read-only nil))
+ (insert msg ?\n)))
+ (set-buffer-modified-p nil))
+ (if (not input)
+ (progn
+ (condition-case ()
+ (and (boundp 'ftp-temp-file-name)
+ ftp-temp-file-name
+ (delete-file ftp-temp-file-name))
+ (error nil))
+ (kill-buffer (current-buffer)))
+ ;; You don't want to look at this.
+ (let ((kludge (generate-new-buffer (format "%s:%s (ftp)"
+ ftp-host ftp-file))))
+ (setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge)))
+ (rename-buffer kludge)
+ ;; ok, you can look again now.
+ (ftp-setup-write-file-hooks)))
+ (if (and asynchronous
+ ;(waiting-for-user-input-p)
+ )
+ (progn (message "%s" msg)
+ (sleep-for 2))))))
+ ((memq (process-status process) '(exit signal))
+ (save-excursion
+ (set-buffer (process-buffer process))
+ (setq msg (format "Ftp died (buffer %s): %s"
+ (buffer-name (current-buffer))
+ msg))
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (insert ?\n ?\n msg))
+ (delete-process proc)
+ (set-buffer (get-buffer-create "*ftp log*"))
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (insert msg))
+ (if (waiting-for-user-input-p)
+ (error "%s" msg))))))
+
+(defun ftp-setup-write-file-hooks ()
+ (let ((hooks write-file-hooks))
+ (make-local-variable 'write-file-hooks)
+ (setq write-file-hooks (append write-file-hooks
+ '(ftp-write-file-hook))))
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'ftp-revert-buffer)
+ (setq default-directory "/tmp/")
+ (setq buffer-file-name (concat default-directory
+ (make-temp-name
+ (buffer-name (current-buffer)))))
+ (setq buffer-read-only nil))
+
+(defun ftp-write-file-hook ()
+ (let ((process (ftp-write-file ftp-host ftp-file)))
+ (set-process-sentinel process 'ftp-synchronous-output-sentinel)
+ (message "FTP writing %s:%s..." ftp-host ftp-file)
+ (while (eq (process-status process) 'run)
+ (condition-case ()
+ (accept-process-output process)
+ (error nil)))
+ (and (eq (process-status process) 'exit)
+ (= (process-exit-status process) 0)
+ (set-buffer-modified-p nil)))
+ (message "Written")
+ t)
+
+(defun ftp-revert-buffer (&rest ignore)
+ (let ((process (ftp-find-file ftp-host ftp-file)))
+ (set-process-sentinel process 'ftp-synchronous-input-sentinel)
+ (message "FTP reverting %s:%s" ftp-host ftp-file)
+ (while (eq (process-status process) 'run)
+ (condition-case ()
+ (accept-process-output process)
+ (error nil)))
+ (and (eq (process-status process) 'exit)
+ (= (process-exit-status process) 0)
+ (set-buffer-modified-p nil))
+ (message "Reverted")))