--- /dev/null
+;;; This is a Completion system for GNU Emacs
+;;;
+;;; E-Mail:
+;;; Internet: completion@think.com, bug-completion@think.com
+;;; UUCP: {rutgers,harvard,mit-eddie}!think!completion
+;;;
+;;; If you are a new user, we'd appreciate knowing your site name and
+;;; any comments you have.
+;;;
+;;;
+;;; NO WARRANTY
+;;;
+;;; This software is distributed free of charge and is in the public domain.
+;;; Anyone may use, duplicate or modify this program. Thinking Machines
+;;; Corporation does not restrict in any way the use of this software by
+;;; anyone.
+;;;
+;;; Thinking Machines Corporation provides absolutely no warranty of any kind.
+;;; The entire risk as to the quality and performance of this program is with
+;;; you. In no event will Thinking Machines Corporation be liable to you for
+;;; damages, including any lost profits, lost monies, or other special,
+;;; incidental or consequential damages arising out of the use of this program.
+;;;
+;;; You must not restrict the distribution of this software.
+;;;
+;;; Please keep this notice and author information in any copies you make.
+;;;
+;;; 4/90
+;;;
+;;;
+;;; Advertisement
+;;;---------------
+;;; Try using this. If you are like most you will be happy you did.
+;;;
+;;; What to put in .emacs
+;;;-----------------------
+;;; (load "completion") ;; If it's not part of the standard band.
+;;; (initialize-completions)
+;;;
+;;; For best results, be sure to byte-compile the file first.
+;;;
+\f
+;;; Authors
+;;;---------
+;;; Jim Salem {salem@think.com}
+;;; Brewster Kahle {brewster@think.com}
+;;; Thinking Machines Corporation
+;;; 245 First St., Cambridge MA 02142 (617) 876-1111
+;;;
+;;; Mailing Lists
+;;;---------------
+;;;
+;;; Bugs to bug-completion@think.com
+;;; Comments to completion@think.com
+;;; Requests to be added completion-request@think.com
+;;;
+;;; Availability
+;;;--------------
+;;; Anonymous FTP from think.com
+;;;
+\f
+;;;---------------------------------------------------------------------------
+;;; Documentation [Slightly out of date]
+;;;---------------------------------------------------------------------------
+;;; (also check the documentation string of the functions)
+;;;
+;;; Introduction
+;;;---------------
+;;;
+;;; After you type a few characters, pressing the "complete" key inserts
+;;; the rest of the word you are likely to type.
+;;;
+;;; This watches all the words that you type and remembers them. When
+;;; typing a new word, pressing "complete" (meta-return) "completes" the
+;;; word by inserting the most recently used word that begins with the
+;;; same characters. If you press meta-return repeatedly, it cycles
+;;; through all the words it knows about.
+;;;
+;;; If you like the completion then just continue typing, it is as if you
+;;; entered the text by hand. If you want the inserted extra characters
+;;; to go away, type control-w or delete. More options are described below.
+;;;
+;;; The guesses are made in the order of the most recently "used". Typing
+;;; in a word and then typing a separator character (such as a space) "uses"
+;;; the word. So does moving a cursor over the word. If no words are found,
+;;; it uses an extended version of the dabbrev style completion.
+;;;
+;;; You automatically save the completions you use to a file between
+;;; sessions.
+;;;
+;;; Completion enables programmers to enter longer, more descriptive
+;;; variable names while typing fewer keystrokes than they normally would.
+;;;
+;;;
+;;; Full documentation
+;;;---------------------
+;;;
+;;; A "word" is any string containing characters with either word or symbol
+;;; syntax. [E.G. Any alphanumeric string with hypens, underscores, etc.]
+;;; Unless you change the constants, you must type at least three characters
+;;; for the word to be recognized. Only words longer than 6 characters are
+;;; saved.
+;;;
+;;; When you load this file, completion will be on. I suggest you use the
+;;; compiled version (because it is noticibly faster).
+;;;
+;;; M-X completion-mode toggles whether or not new words are added to the
+;;; database by changing the value of *completep*.
+;;;
+;;; SAVING/LOADING COMPLETIONS
+;;; Completions are automatically saved from one session to another
+;;; (unless *save-completions-p* or *completep* is nil).
+;;; Loading this file (or calling initialize-completions) causes EMACS
+;;; to load a completions database for a saved completions file
+;;; (default: ~/.completions). When you exit, EMACS saves a copy of the
+;;; completions that you
+;;; often use. When you next start, EMACS loads in the saved completion file.
+;;;
+;;; The number of completions saved depends loosely on
+;;; *saved-completions-decay-factor*. Completions that have never been
+;;; inserted via "complete" are not saved. You are encouraged to experiment
+;;; with different functions (see compute-completion-min-num-uses).
+;;;
+;;; Some completions are permanent and are always saved out. These
+;;; completions have their num-uses slot set to T. Use
+;;; add-permanent-completion to do this
+;;;
+;;; Completions are saved only if *completep* is T. The number of old
+;;; versions kept of the saved completions file is controlled by
+;;; *completion-file-versions-kept*.
+;;;
+;;; COMPLETE KEY OPTIONS
+;;; The complete function takes a numeric arguments.
+;;; control-u :: leave the point at the beginning of the completion rather
+;;; than the middle.
+;;; a number :: rotate through the possible completions by that amount
+;;; `-' :: same as -1 (insert previous completion)
+;;;
+;;; HOW THE DATABASE IS MAINTAINED
+;;; <write>
+;;;
+;;; UPDATING THE DATABASE MANUALLY
+;;; m-x kill-completion
+;;; kills the completion at point.
+;;; m-x add-completion
+;;; m-x add-permanent-completion
+;;;
+;;; UPDATING THE DATABASE FROM A SOURCE CODE FILE
+;;; m-x add-completions-from-buffer
+;;; Parses all the definition names from a C or LISP mode buffer and
+;;; adds them to the completion database.
+;;;
+;;; m-x add-completions-from-lisp-file
+;;; Parses all the definition names from a C or Lisp mode file and
+;;; adds them to the completion database.
+;;;
+;;; UPDATING THE DATABASE FROM A TAGS TABLE
+;;; m-x add-completions-from-tags-table
+;;; Adds completions from the current tags-table-buffer.
+;;;
+;;; HOW A COMPLETION IS FOUND
+;;; <write>
+;;;
+;;; STRING CASING
+;;; Completion is string case independent if case-fold-search has its
+;;; normal default of T. Also when the completion is inserted the case of the
+;;; entry is coerced appropriately.
+;;; [E.G. APP --> APPROPRIATELY app --> appropriately
+;;; App --> Appropriately]
+;;;
+;;; INITIALIZATION
+;;; The form `(initialize-completions)' initializes the completion system by
+;;; trying to load in the user's completions. After the first cal, further
+;;; calls have no effect so one should be careful not to put the form in a
+;;; site's standard site-init file.
+;;;
+;;;---------------------------------------------------------------------------
+;;;
+;;;
+\f
+;;;-----------------------------------------------
+;;; Porting Notes
+;;;-----------------------------------------------
+;;;
+;;; Should run on 18.49, 18.52, and 19.0
+;;; Tested on vanilla version.
+;;; This requires the standard cl.el file. It could easily rewritten to not
+;;; require it. It defines remove which is not in cl.el.
+;;;
+;;; FUNCTIONS BASHED
+;;; The following functions are bashed but it is done carefully and should not
+;;; cause problems ::
+;;; kill-region, next-line, previous-line, newline, newline-and-indent,
+;;; kill-emacs
+;;;
+;;;
+;;;---------------------------------------------------------------------------
+;;; Functions you might like to call
+;;;---------------------------------------------------------------------------
+;;;
+;;; add-completion string &optional num-uses
+;;; Adds a new string to the database
+;;;
+;;; add-permanent-completion string
+;;; Adds a new string to the database with num-uses = T
+;;;
+
+;;; kill-completion string
+;;; Kills the completion from the database.
+;;;
+;;; clear-all-completions
+;;; Clears the database
+;;;
+;;; list-all-completions
+;;; Returns a list of all completions.
+;;;
+;;;
+;;; next-completion string &optional index
+;;; Returns a completion entry that starts with string.
+;;;
+;;; find-exact-completion string
+;;; Returns a completion entry that exactly matches string.
+;;;
+;;; complete
+;;; Inserts a completion at point
+;;;
+;;; initialize-completions
+;;; Loads the completions file and sets up so that exiting emacs will
+;;; save them.
+;;;
+;;; save-completions-to-file &optional filename
+;;; load-completions-from-file &optional filename
+;;;
+;;;-----------------------------------------------
+;;; Other functions
+;;;-----------------------------------------------
+;;;
+;;; get-completion-list string
+;;;
+;;; These things are for manipulating the structure
+;;; make-completion string num-uses
+;;; completion-num-uses completion
+;;; completion-string completion
+;;; set-completion-num-uses completion num-uses
+;;; set-completion-string completion string
+;;;
+;;;
+\f
+;;;-----------------------------------------------
+;;; To Do :: (anybody ?)
+;;;-----------------------------------------------
+;;;
+;;; Implement Lookup and keyboard interface in C
+;;; Add package prefix smarts (for Common Lisp)
+;;; Add autoprompting of possible completions after every keystroke (fast
+;;; terminals only !)
+;;; Add doc. to texinfo
+;;;
+;;;
+;;;-----------------------------------------------
+;;; History ::
+;;;-----------------------------------------------
+;;; Sometime in '84 Brewster implemented a somewhat buggy version for
+;;; Symbolics LISPMs.
+;;; Jan. '85 Jim became enamored of the idea and implemented a faster,
+;;; more robust version.
+;;; With input from many users at TMC, (rose, craig, and gls come to mind),
+;;; the current style of interface was developed.
+;;; 9/87, Jim and Brewster took terminals home. Yuck. After
+;;; complaining for a while Brewester implemented a subset of the current
+;;; LISPM version for GNU Emacs.
+;;; 8/88 After complaining for a while (and with sufficient
+;;; promised rewards), Jim reimplemented a version of GNU completion
+;;; superior to that of the LISPM version.
+;;;
+;;;-----------------------------------------------
+;;; Acknowlegements
+;;;-----------------------------------------------
+;;; Cliff Lasser (cal@think.com), Kevin Herbert (kph@cisco.com),
+;;; eero@media-lab, kgk@cs.brown.edu, jla@ai.mit.edu,
+;;;
+;;;-----------------------------------------------
+;;; Change Log
+;;;-----------------------------------------------
+;;; From version 9 to 10
+;;; - Allowance for non-integral *completion-version* nos.
+;;; - Fix cmpl-apply-as-top-level for keyboard macros
+;;; - Fix broken completion merging (in save-completions-to-file)
+;;; - More misc. fixes for version 19.0 of emacs
+;;;
+;;; From Version 8 to 9
+;;; - Ported to version 19.0 of emacs (backcompatible with version 18)
+;;; - Added add-completions-from-tags-table (with thanks to eero@media-lab)
+;;;
+;;; From Version 7 to 8
+;;; - Misc. changes to comments
+;;; - new completion key bindings: c-x o, M->, M-<, c-a, c-e
+;;; - cdabbrev now checks all the visible window buffers and the "other buffer"
+;;; - `%' is now a symbol character rather than a separator (except in C mode)
+;;;
+;;; From Version 6 to 7
+;;; - Fixed bug with saving out .completion file the first time
+;;;
+;;; From Version 5 to 6
+;;; - removed statistics recording
+;;; - reworked advise to handle autoloads
+;;; - Fixed fortran mode support
+;;; - Added new cursor motion triggers
+;;;
+;;; From Version 4 to 5
+;;; - doesn't bother saving if nothing has changed
+;;; - auto-save if haven't used for a 1/2 hour
+;;; - save period extended to two weeks
+;;; - minor fix to capitalization code
+;;; - added *completion-auto-save-period* to variables recorded.
+;;; - added reenter protection to cmpl-record-statistics-filter
+;;; - added backup protection to save-completions-to-file (prevents
+;;; problems with disk full errors)
+\f
+;;;-----------------------------------------------
+;;; Requires
+;;; Version
+;;;-----------------------------------------------
+
+;;(require 'cl) ;; DOTIMES, etc. {actually done after variable defs.}
+
+(defconst *completion-version* 10
+ "Tested for EMACS versions 18.49, 18.52, 18.55 and beyond and 19.0.")
+
+;;;---------------------------------------------------------------------------
+;;; User changeable parameters
+;;;---------------------------------------------------------------------------
+
+(defvar *completep* t
+ "*Set to nil to turn off the completion hooks.
+(No new words added to the database or saved to the init file)."
+ )
+
+(defvar *save-completions-p* t
+ "*If non-nil, the most useful completions are saved to disk when
+exiting EMACS. See *saved-completions-decay-factor*.")
+
+(defvar *saved-completions-filename* "~/.completions"
+ "*The filename to save completions to.")
+
+(defvar *saved-completion-retention-time* 336
+ "*The maximum amout of time to save a completion for if it has not been used.
+In hours. (1 day = 24, 1 week = 168). If this is 0, non-permanent completions
+will not be saved unless these are used. Default is two weeks."
+ )
+
+(defvar *separator-character-uses-completion-p* nil
+ "*If non-nil, typing a separator character after a completion symbol that
+is not part of the database marks it as used (so it will be saved).")
+
+(defvar *completion-file-versions-kept* kept-new-versions
+ "*Set this to the number of versions you want save-completions-to-file
+to keep.")
+
+(defvar *print-next-completion-speed-threshold* 4800
+ "*The baud rate at or above which to print the next potential completion
+after inserting the current one."
+ )
+
+(defvar *print-next-completion-does-cdabbrev-search-p* nil
+ "*If non-NIL, the next completion prompt will also do a cdabbrev search.
+This can be time consuming.")
+
+(defvar *cdabbrev-radius* 15000
+ "*How far to search for cdabbrevs. In number of characters. If nil, the
+whole buffer is searched.")
+
+(defvar *modes-for-completion-find-file-hook* '(lisp c)
+ "*A list of modes {either c or lisp}. Definitions from visited files
+of those types are automatically added to the completion database.")
+
+(defvar *record-cmpl-statistics-p* nil
+ "*If non-nil, statistics are automatically recorded.")
+
+(defvar *completion-auto-save-period* 1800
+ "*The period in seconds to wait for emacs to be idle before autosaving
+the completions. Default is a 1/2 hour.")
+
+(defconst *completion-min-length* nil ;; defined below in eval-when
+ "*The minimum length of a stored completion.
+DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
+
+(defconst *completion-max-length* nil ;; defined below in eval-when
+ "*The maximum length of a stored completion.
+DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
+
+(defconst *completion-prefix-min-length* nil ;; defined below in eval-when
+ "The minimum length of a completion search string.
+DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
+
+(defmacro eval-when-compile-load-eval (&rest body)
+ ;; eval everything before expanding
+ (mapcar 'eval body)
+ (cons 'progn body)
+ )
+
+(defun completion-eval-when ()
+ (eval-when-compile-load-eval
+ ;; These vars. are defined at both compile and load time.
+ (setq *completion-min-length* 6)
+ (setq *completion-max-length* 200)
+ (setq *completion-prefix-min-length* 3)
+ ;; Need this file around too
+ (require 'cl)
+ )) ;; eval-when
+
+(completion-eval-when)
+
+;;;---------------------------------------------------------------------------
+;;; Internal Variables
+;;;---------------------------------------------------------------------------
+
+(defvar cmpl-initialized-p nil
+ "Set to t when the completion system is initialized. Indicates that the old
+completion file has been read in.")
+
+(defvar cmpl-completions-accepted-p nil
+ "Set to T as soon as the first completion has been accepted. Used to
+decide whether to save completions.")
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Low level tools
+;;;---------------------------------------------------------------------------
+
+;;;-----------------------------------------------
+;;; Misc.
+;;;-----------------------------------------------
+
+(defun remove (item list)
+ (setq list (copy-sequence list))
+ (delq item list)
+ )
+
+(defun minibuffer-window-selected-p ()
+ "True iff the current window is the minibuffer."
+ (eq (minibuffer-window) (selected-window)))
+
+(eval-when-compile-load-eval
+(defun function-needs-autoloading-p (symbol)
+ ;; True iff symbol is represents an autoloaded function and has not yet been
+ ;; autoloaded.
+ (and (listp (symbol-function symbol))
+ (eq 'autoload (car (symbol-function symbol)))
+ ))
+) ;; eval-when
+
+(defun function-defined-and-loaded (symbol)
+ ;; True iff symbol is bound to a loaded function.
+ (and (fboundp symbol) (not (function-needs-autoloading-p symbol)))
+ )
+
+(defmacro read-time-eval (form)
+ ;; Like the #. reader macro
+ (eval form)
+ )
+
+;;;-----------------------------------------------
+;;; Emacs Version 19 compatibility
+;;;-----------------------------------------------
+
+(defconst emacs-is-version-19 (string= (substring emacs-version 0 2) "19"))
+
+(defun cmpl19-baud-rate ()
+ (if emacs-is-version-19
+ baud-rate
+ (baud-rate)))
+
+(defun cmpl19-sit-for (amount)
+ (if (and emacs-is-version-19 (= amount 0))
+ (sit-for 1 t)
+ (sit-for amount)))
+
+;;;-----------------------------------------------
+;;; Advise
+;;;-----------------------------------------------
+
+(defmacro completion-advise (function-name where &rest body)
+ "Adds the body code before calling function. This advise is not compiled.
+WHERE is either :BEFORE or :AFTER."
+ (completion-advise-1 function-name where body)
+ )
+
+(defmacro cmpl-apply-as-top-level (function arglist)
+ "Calls function-name interactively if inside a call-interactively."
+ (list 'cmpl-apply-as-top-level-1 function arglist
+ '(let ((executing-macro nil)) (interactive-p)))
+ )
+
+(defun cmpl-apply-as-top-level-1 (function arglist interactive-p)
+ (if (and interactive-p (commandp function))
+ (call-interactively function)
+ (apply function arglist)
+ ))
+
+(eval-when-compile-load-eval
+
+(defun cmpl-defun-preamble (function-name)
+ (let ((doc-string
+ (condition-case e
+ ;; This condition-case is here to stave
+ ;; off bizarre load time errors 18.52 gets
+ ;; on the function c-mode
+ (documentation function-name)
+ (error nil)))
+ (interactivep (commandp function-name))
+ )
+ (append
+ (if doc-string (list doc-string))
+ (if interactivep '((interactive)))
+ )))
+
+(defun completion-advise-1 (function-name where body &optional new-name)
+ (unless new-name (setq new-name function-name))
+ (let ((quoted-name (list 'quote function-name))
+ (quoted-new-name (list 'quote new-name))
+ )
+
+ (cond ((function-needs-autoloading-p function-name)
+ (list* 'defun function-name '(&rest arglist)
+ (append
+ (cmpl-defun-preamble function-name)
+ (list (list 'load (second (symbol-function function-name)))
+ (list 'eval
+ (list 'completion-advise-1 quoted-name
+ (list 'quote where) (list 'quote body)
+ quoted-new-name))
+ (list 'cmpl-apply-as-top-level quoted-new-name 'arglist)
+ )))
+ )
+ (t
+ (let ((old-def-name
+ (intern (concat "$$$cmpl-" (symbol-name function-name))))
+ )
+
+ (list 'progn
+ (list 'defvar old-def-name
+ (list 'symbol-function quoted-name))
+ (list* 'defun new-name '(&rest arglist)
+ (append
+ (cmpl-defun-preamble function-name)
+ (ecase where
+ (:before
+ (list (cons 'progn body)
+ (list 'cmpl-apply-as-top-level
+ old-def-name 'arglist)))
+ (:after
+ (list* (list 'cmpl-apply-as-top-level
+ old-def-name 'arglist)
+ body)
+ )))
+ )))
+ ))))
+) ;; eval-when
+
+
+;;;-----------------------------------------------
+;;; String case coercion
+;;;-----------------------------------------------
+
+(defun cmpl-string-case-type (string)
+ "Returns :capitalized, :up, :down, :mixed, or :neither."
+ (let ((case-fold-search nil))
+ (cond ((string-match "[a-z]" string)
+ (cond ((string-match "[A-Z]" string)
+ (cond ((and (> (length string) 1)
+ (null (string-match "[A-Z]" string 1)))
+ ':capitalized)
+ (t
+ ':mixed)))
+ (t ':down)))
+ (t
+ (cond ((string-match "[A-Z]" string)
+ ':up)
+ (t ':neither))))
+ ))
+
+;;; Tests -
+;;; (cmpl-string-case-type "123ABCDEF456") --> :up
+;;; (cmpl-string-case-type "123abcdef456") --> :down
+;;; (cmpl-string-case-type "123aBcDeF456") --> :mixed
+;;; (cmpl-string-case-type "123456") --> :neither
+;;; (cmpl-string-case-type "Abcde123") --> :capitalized
+
+(defun cmpl-coerce-string-case (string case-type)
+ (cond ((eq case-type ':down) (downcase string))
+ ((eq case-type ':up) (upcase string))
+ ((eq case-type ':capitalized)
+ (setq string (downcase string))
+ (aset string 0 (logand ?\337 (aref string 0)))
+ string)
+ (t string)
+ ))
+
+(defun cmpl-merge-string-cases (string-to-coerce given-string)
+ (let ((string-case-type (cmpl-string-case-type string-to-coerce))
+ )
+ (cond ((memq string-case-type '(:down :up :capitalized))
+ ;; Found string is in a standard case. Coerce to a type based on
+ ;; the given string
+ (cmpl-coerce-string-case string-to-coerce
+ (cmpl-string-case-type given-string))
+ )
+ (t
+ ;; If the found string is in some unusual case, just insert it
+ ;; as is
+ string-to-coerce)
+ )))
+
+;;; Tests -
+;;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456
+;;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456
+;;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456
+;;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456
+
+\f
+;;;-----------------------------------------------
+;;; Emacs Idle Time hooks
+;;;-----------------------------------------------
+
+(defvar cmpl-emacs-idle-process nil)
+
+(defvar cmpl-emacs-idle-interval 150
+ "Seconds between running the emacs idle process.")
+
+(defun init-cmpl-emacs-idle-process ()
+ "Initialize the emacs idle process."
+ (let ((live (and cmpl-emacs-idle-process
+ (eq (process-status cmpl-emacs-idle-process) 'run)))
+ ;; do not allocate a pty
+ (process-connection-type nil))
+ (if live
+ (kill-process cmpl-emacs-idle-process))
+ (if cmpl-emacs-idle-process
+ (delete-process cmpl-emacs-idle-process))
+ (setq cmpl-emacs-idle-process
+ (start-process "cmpl-emacs-idle" nil
+ "loadst"
+ "-n" (int-to-string cmpl-emacs-idle-interval)))
+ (process-kill-without-query cmpl-emacs-idle-process)
+ (set-process-filter cmpl-emacs-idle-process 'cmpl-emacs-idle-filter)
+ ))
+
+(defvar cmpl-emacs-buffer nil)
+(defvar cmpl-emacs-point 0)
+(defvar cmpl-emacs-last-command nil)
+(defvar cmpl-emacs-last-command-char nil)
+(defun cmpl-emacs-idle-p ()
+ ;; returns T if emacs has been idle
+ (if (and (eq cmpl-emacs-buffer (current-buffer))
+ (= cmpl-emacs-point (point))
+ (eq cmpl-emacs-last-command last-command)
+ (eq last-command-char last-command-char)
+ )
+ t ;; idle
+ ;; otherwise, update count
+ (setq cmpl-emacs-buffer (current-buffer))
+ (setq cmpl-emacs-point (point))
+ (setq cmpl-emacs-last-command last-command)
+ (setq last-command-char last-command-char)
+ nil
+ ))
+
+(defvar cmpl-emacs-idle-time 0
+ "The idle time of emacs in seconds.")
+
+(defvar inside-cmpl-emacs-idle-filter nil)
+(defvar cmpl-emacs-idle-time-hooks nil)
+
+(defun cmpl-emacs-idle-filter (proc string)
+ ;; This gets called every cmpl-emacs-idle-interval seconds
+ ;; Update idle time clock
+ (if (cmpl-emacs-idle-p)
+ (incf cmpl-emacs-idle-time cmpl-emacs-idle-interval)
+ (setq cmpl-emacs-idle-time 0))
+
+ (unless inside-cmpl-emacs-idle-filter
+ ;; Don't reenter if we are hung
+
+ (setq inside-cmpl-emacs-idle-filter t)
+
+ (dolist (function cmpl-emacs-idle-time-hooks)
+ (condition-case e
+ (funcall function)
+ (error nil)
+ ))
+ (setq inside-cmpl-emacs-idle-filter nil)
+ ))
+
+\f
+;;;-----------------------------------------------
+;;; Time
+;;;-----------------------------------------------
+;;; What a backwards way to get the time ! Unfortunately, GNU Emacs
+;;; doesn't have an accessible time function.
+
+(defconst cmpl-hours-per-day 24)
+(defconst cmpl-hours-per-year (* 365 cmpl-hours-per-day))
+(defconst cmpl-hours-per-4-years (+ (* 4 cmpl-hours-per-year)
+ cmpl-hours-per-day))
+(defconst cmpl-days-since-start-of-year
+ '(0 31 59 90 120 151 181 212 243 273 304 334))
+(defconst cmpl-days-since-start-of-leap-year
+ '(0 31 60 91 121 152 182 213 244 274 305 335))
+(defconst cmpl-months
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+ )
+
+(defun cmpl-hours-since-1900-internal (month day year hours)
+ "Month is an integer from 1 to 12. Year is a two digit integer (19XX)"
+ (+ ;; Year
+ (* (/ (1- year) 4) cmpl-hours-per-4-years)
+ (* (1+ (mod (1- year) 4)) cmpl-hours-per-year)
+ ;; minus two to account for 1968 rather than 1900
+ ;; month
+ (* cmpl-hours-per-day
+ (nth (1- month) (if (zerop (mod year 4))
+ cmpl-days-since-start-of-leap-year
+ cmpl-days-since-start-of-year)))
+ (* (1- day) cmpl-hours-per-day)
+ hours
+ ))
+
+(defun cmpl-month-from-string (month-string)
+ "Month string is a three char. month string"
+ (let ((count 1))
+ (do ((list cmpl-months (cdr list))
+ )
+ ((or (null list) (string-equal month-string (car list))))
+ (setq count (1+ count)))
+ (if (> count 12)
+ (error "Unknown month - %s" month-string))
+ count))
+
+(defun cmpl-hours-since-1900 (&optional time-string)
+ "String is a string in the format of current-time-string (the default)."
+ (let* ((string (or time-string (current-time-string)))
+ (month (cmpl-month-from-string (substring string 4 7)))
+ (day (string-to-int (substring string 8 10)))
+ (year (string-to-int (substring string 22 24)))
+ (hour (string-to-int (substring string 11 13)))
+ )
+ (cmpl-hours-since-1900-internal month day year hour)
+ ))
+
+;;; Tests -
+;;;(cmpl-hours-since-1900 "Wed Jan 1 00:00:28 1900") --> 35040
+;;;(cmpl-hours-since-1900 "Wed Nov 2 23:00:28 1988") --> 778751
+;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1988") --> 771926
+;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1988") --> 772670
+;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1988") --> 773366
+;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1988") --> 774110
+;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1988") --> 774830
+;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1988") --> 775574
+;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1988") --> 776294
+;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1988") --> 777038
+;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1988") --> 777782
+;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1988") --> 778502
+;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1988") --> 779246
+;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1988") --> 779966
+;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1957") --> 500198
+;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1957") --> 500942
+;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1957") --> 501614
+;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1957") --> 502358
+;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1957") --> 503078
+;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1957") --> 503822
+;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1957") --> 504542
+;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1957") --> 505286
+;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1957") --> 506030
+;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1957") --> 506750
+;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1957") --> 507494
+;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1957") --> 508214
+
+\f
+;;;---------------------------------------------------------------------------
+;;; "Symbol" parsing functions
+;;;---------------------------------------------------------------------------
+;;; The functions symbol-before-point, symbol-under-point, etc. quickly return
+;;; an appropriate symbol string. The strategy is to temporarily change
+;;; the syntax table to enable fast symbol searching. There are three classes
+;;; of syntax in these "symbol" syntax tables ::
+;;;
+;;; syntax (?_) - "symbol" chars (e.g. alphanumerics)
+;;; syntax (?w) - symbol chars to ignore at end of words (e.g. period).
+;;; syntax (? ) - everything else
+;;;
+;;; Thus by judicious use of scan-sexps and forward-word, we can get
+;;; the word we want relatively fast and without consing.
+;;;
+;;; Why do we need a separate category for "symbol chars to ignore at ends" ?
+;;; For example, in LISP we want starting :'s trimmed
+;;; so keyword argument specifiers also define the keyword completion. And,
+;;; for example, in C we want `.' appearing in a structure ref. to
+;;; be kept intact in order to store the whole structure ref.; however, if
+;;; it appears at the end of a symbol it should be discarded because it is
+;;; probably used as a period.
+
+;;; Here is the default completion syntax ::
+;;; Symbol chars :: A-Z a-z 0-9 @ / \ * + ~ $ < > %
+;;; Symbol chars to ignore at ends :: _ : . -
+;;; Separator chars. :: <tab> <space> ! ^ & ( ) = ` | { } [ ] ; " ' #
+;;; , ? <Everything else>
+
+;;; Mode specific differences and notes ::
+;;; LISP diffs ->
+;;; Symbol chars :: ! & ? = ^
+;;;
+;;; C diffs ->
+;;; Separator chars :: + * / : %
+;;; A note on the hypen (`-'). Perhaps, the hypen should also be a separator
+;;; char., however, we wanted to have completion symbols include pointer
+;;; references. For example, "foo->bar" is a symbol as far as completion is
+;;; concerned.
+;;;
+;;; FORTRAN diffs ->
+;;; Separator chars :: + - * / :
+;;;
+;;; Pathname diffs ->
+;;; Symbol chars :: .
+;;; Of course there is no pathname "mode" and in fact we have not implemented
+;;; this table. However, if there was such a mode, this is what it would look
+;;; like.
+
+;;;-----------------------------------------------
+;;; Table definitions
+;;;-----------------------------------------------
+
+(defun make-standard-completion-syntax-table ()
+ (let ((table (make-vector 256 0)) ;; default syntax is whitespace
+ )
+ ;; alpha chars
+ (dotimes (i 26)
+ (modify-syntax-entry (+ ?a i) "_" table)
+ (modify-syntax-entry (+ ?A i) "_" table))
+ ;; digit chars.
+ (dotimes (i 10)
+ (modify-syntax-entry (+ ?0 i) "_" table))
+ ;; Other ones
+ (let ((symbol-chars '(?@ ?/ ?\\ ?* ?+ ?~ ?$ ?< ?> ?%))
+ (symbol-chars-ignore '(?_ ?- ?: ?.))
+ )
+ (dolist (char symbol-chars)
+ (modify-syntax-entry char "_" table))
+ (dolist (char symbol-chars-ignore)
+ (modify-syntax-entry char "w" table)
+ )
+ )
+ table))
+
+(defconst cmpl-standard-syntax-table (make-standard-completion-syntax-table))
+
+(defun make-lisp-completion-syntax-table ()
+ (let ((table (copy-syntax-table cmpl-standard-syntax-table))
+ (symbol-chars '(?! ?& ?? ?= ?^))
+ )
+ (dolist (char symbol-chars)
+ (modify-syntax-entry char "_" table))
+ table))
+
+(defun make-c-completion-syntax-table ()
+ (let ((table (copy-syntax-table cmpl-standard-syntax-table))
+ (separator-chars '(?+ ?* ?/ ?: ?%))
+ )
+ (dolist (char separator-chars)
+ (modify-syntax-entry char " " table))
+ table))
+
+(defun make-fortran-completion-syntax-table ()
+ (let ((table (copy-syntax-table cmpl-standard-syntax-table))
+ (separator-chars '(?+ ?- ?* ?/ ?:))
+ )
+ (dolist (char separator-chars)
+ (modify-syntax-entry char " " table))
+ table))
+
+(defconst cmpl-lisp-syntax-table (make-lisp-completion-syntax-table))
+(defconst cmpl-c-syntax-table (make-c-completion-syntax-table))
+(defconst cmpl-fortran-syntax-table (make-fortran-completion-syntax-table))
+
+(defvar cmpl-syntax-table cmpl-standard-syntax-table
+ "This variable holds the current completion syntax table.")
+(make-variable-buffer-local 'cmpl-syntax-table)
+
+;;;-----------------------------------------------
+;;; Installing the appropriate mode tables
+;;;-----------------------------------------------
+
+(completion-advise lisp-mode-variables :after
+ (setq cmpl-syntax-table cmpl-lisp-syntax-table)
+ )
+
+(completion-advise c-mode :after
+ (setq cmpl-syntax-table cmpl-c-syntax-table)
+ )
+
+(completion-advise fortran-mode :after
+ (setq cmpl-syntax-table cmpl-fortran-syntax-table)
+ (completion-setup-fortran-mode)
+ )
+
+;;;-----------------------------------------------
+;;; Symbol functions
+;;;-----------------------------------------------
+(defvar cmpl-symbol-start nil
+ "Set to the first character of the symbol after one of the completion
+symbol functions is called.")
+(defvar cmpl-symbol-end nil
+ "Set to the last character of the symbol after one of the completion
+symbol functions is called.")
+;;; These are temp. vars. we use to avoid using let.
+;;; Why ? Small speed improvement.
+(defvar cmpl-saved-syntax nil)
+(defvar cmpl-saved-point nil)
+
+(defun symbol-under-point ()
+ "Returns the symbol that the point is currently on if it is longer
+than *completion-min-length*."
+ (setq cmpl-saved-syntax (syntax-table))
+ (set-syntax-table cmpl-syntax-table)
+ (cond
+ ;; Cursor is on following-char and after preceding-char
+ ((memq (char-syntax (following-char)) '(?w ?_))
+ (setq cmpl-saved-point (point)
+ cmpl-symbol-start (scan-sexps (1+ cmpl-saved-point) -1)
+ cmpl-symbol-end (scan-sexps cmpl-saved-point 1))
+ ;; remove chars to ignore at the start
+ (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
+ (goto-char cmpl-symbol-start)
+ (forward-word 1)
+ (setq cmpl-symbol-start (point))
+ (goto-char cmpl-saved-point)
+ ))
+ ;; remove chars to ignore at the end
+ (cond ((= (char-syntax (char-after (1- cmpl-symbol-end))) ?w)
+ (goto-char cmpl-symbol-end)
+ (forward-word -1)
+ (setq cmpl-symbol-end (point))
+ (goto-char cmpl-saved-point)
+ ))
+ ;; restore state
+ (set-syntax-table cmpl-saved-syntax)
+ ;; Return completion if the length is reasonable
+ (if (and (<= (read-time-eval *completion-min-length*)
+ (- cmpl-symbol-end cmpl-symbol-start))
+ (<= (- cmpl-symbol-end cmpl-symbol-start)
+ (read-time-eval *completion-max-length*)))
+ (buffer-substring cmpl-symbol-start cmpl-symbol-end))
+ )
+ (t
+ ;; restore table if no symbol
+ (set-syntax-table cmpl-saved-syntax)
+ nil)
+ ))
+
+;;; tests for symbol-under-point
+;;; `^' indicates cursor pos. where value is returned
+;;; simple-word-test
+;;; ^^^^^^^^^^^^^^^^ --> simple-word-test
+;;; _harder_word_test_
+;;; ^^^^^^^^^^^^^^^^^^ --> harder_word_test
+;;; .___.______.
+;;; --> nil
+;;; /foo/bar/quux.hello
+;;; ^^^^^^^^^^^^^^^^^^^ --> /foo/bar/quux.hello
+;;;
+
+(defun symbol-before-point ()
+ "Returns a string of the symbol immediately before point
+or nil if there isn't one longer than *completion-min-length*."
+ ;; This is called when a word separator is typed so it must be FAST !
+ (setq cmpl-saved-syntax (syntax-table))
+ (set-syntax-table cmpl-syntax-table)
+ ;; Cursor is on following-char and after preceding-char
+ (cond ((= (setq cmpl-preceding-syntax (char-syntax (preceding-char))) ?_)
+ ;; No chars. to ignore at end
+ (setq cmpl-symbol-end (point)
+ cmpl-symbol-start (scan-sexps (1+ cmpl-symbol-end) -1)
+ )
+ ;; remove chars to ignore at the start
+ (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
+ (goto-char cmpl-symbol-start)
+ (forward-word 1)
+ (setq cmpl-symbol-start (point))
+ (goto-char cmpl-symbol-end)
+ ))
+ ;; restore state
+ (set-syntax-table cmpl-saved-syntax)
+ ;; return value if long enough
+ (if (>= cmpl-symbol-end
+ (+ cmpl-symbol-start
+ (read-time-eval *completion-min-length*)))
+ (buffer-substring cmpl-symbol-start cmpl-symbol-end))
+ )
+ ((= cmpl-preceding-syntax ?w)
+ ;; chars to ignore at end
+ (setq cmpl-saved-point (point)
+ cmpl-symbol-start (scan-sexps (1+ cmpl-saved-point) -1))
+ ;; take off chars. from end
+ (forward-word -1)
+ (setq cmpl-symbol-end (point))
+ ;; remove chars to ignore at the start
+ (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
+ (goto-char cmpl-symbol-start)
+ (forward-word 1)
+ (setq cmpl-symbol-start (point))
+ ))
+ ;; restore state
+ (goto-char cmpl-saved-point)
+ (set-syntax-table cmpl-saved-syntax)
+ ;; Return completion if the length is reasonable
+ (if (and (<= (read-time-eval *completion-min-length*)
+ (- cmpl-symbol-end cmpl-symbol-start))
+ (<= (- cmpl-symbol-end cmpl-symbol-start)
+ (read-time-eval *completion-max-length*)))
+ (buffer-substring cmpl-symbol-start cmpl-symbol-end))
+ )
+ (t
+ ;; restore table if no symbol
+ (set-syntax-table cmpl-saved-syntax)
+ nil)
+ ))
+
+;;; tests for symbol-before-point
+;;; `^' indicates cursor pos. where value is returned
+;;; simple-word-test
+;;; ^ --> nil
+;;; ^ --> nil
+;;; ^ --> simple-w
+;;; ^ --> simple-word-test
+;;; _harder_word_test_
+;;; ^ --> harder_word_test
+;;; ^ --> harder_word_test
+;;; ^ --> harder
+;;; .___....
+;;; --> nil
+
+(defun symbol-under-or-before-point ()
+ ;;; This could be made slightly faster but it is better to avoid
+ ;;; copying all the code.
+ ;;; However, it is only used by the completion string prompter.
+ ;;; If it comes into common use, it could be rewritten.
+ (setq cmpl-saved-syntax (syntax-table))
+ (set-syntax-table cmpl-syntax-table)
+ (cond ((memq (char-syntax (following-char)) '(?w ?_))
+ (set-syntax-table cmpl-saved-syntax)
+ (symbol-under-point))
+ (t
+ (set-syntax-table cmpl-saved-syntax)
+ (symbol-before-point))
+ ))
+
+
+(defun symbol-before-point-for-complete ()
+ ;; "Returns a string of the symbol immediately before point
+ ;; or nil if there isn't one. Like symbol-before-point but doesn't trim the
+ ;; end chars."
+ ;; Cursor is on following-char and after preceding-char
+ (setq cmpl-saved-syntax (syntax-table))
+ (set-syntax-table cmpl-syntax-table)
+ (cond ((memq (setq cmpl-preceding-syntax (char-syntax (preceding-char)))
+ '(?_ ?w))
+ (setq cmpl-symbol-end (point)
+ cmpl-symbol-start (scan-sexps (1+ cmpl-symbol-end) -1)
+ )
+ ;; remove chars to ignore at the start
+ (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
+ (goto-char cmpl-symbol-start)
+ (forward-word 1)
+ (setq cmpl-symbol-start (point))
+ (goto-char cmpl-symbol-end)
+ ))
+ ;; restore state
+ (set-syntax-table cmpl-saved-syntax)
+ ;; Return completion if the length is reasonable
+ (if (and (<= (read-time-eval
+ *completion-prefix-min-length*)
+ (- cmpl-symbol-end cmpl-symbol-start))
+ (<= (- cmpl-symbol-end cmpl-symbol-start)
+ (read-time-eval *completion-max-length*)))
+ (buffer-substring cmpl-symbol-start cmpl-symbol-end))
+ )
+ (t
+ ;; restore table if no symbol
+ (set-syntax-table cmpl-saved-syntax)
+ nil)
+ ))
+
+;;; tests for symbol-before-point-for-complete
+;;; `^' indicates cursor pos. where value is returned
+;;; simple-word-test
+;;; ^ --> nil
+;;; ^ --> nil
+;;; ^ --> simple-w
+;;; ^ --> simple-word-test
+;;; _harder_word_test_
+;;; ^ --> harder_word_test
+;;; ^ --> harder_word_test_
+;;; ^ --> harder_
+;;; .___....
+;;; --> nil
+
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Statistics Recording
+;;;---------------------------------------------------------------------------
+
+;;; Note that the guts of this has been turned off. The guts
+;;; are in completion-stats.el.
+
+;;;-----------------------------------------------
+;;; Conditionalizing code on *record-cmpl-statistics-p*
+;;;-----------------------------------------------
+;;; All statistics code outside this block should use this
+(defmacro cmpl-statistics-block (&rest body)
+ "Only executes body if we are recording statistics."
+ (list 'cond
+ (list* '*record-cmpl-statistics-p* body)
+ ))
+
+;;;-----------------------------------------------
+;;; Completion Sources
+;;;-----------------------------------------------
+
+;; ID numbers
+(defconst cmpl-source-unknown 0)
+(defconst cmpl-source-init-file 1)
+(defconst cmpl-source-file-parsing 2)
+(defconst cmpl-source-separator 3)
+(defconst cmpl-source-cursor-moves 4)
+(defconst cmpl-source-interactive 5)
+(defconst cmpl-source-cdabbrev 6)
+(defconst num-cmpl-sources 7)
+(defvar current-completion-source cmpl-source-unknown)
+
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Completion Method #2: dabbrev-expand style
+;;;---------------------------------------------------------------------------
+;;;
+;;; This method is used if there are no useful stored completions. It is
+;;; based on dabbrev-expand with these differences :
+;;; 1) Faster (we don't use regexps)
+;;; 2) case coercion handled correctly
+;;; This is called cdabbrev to differentiate it.
+;;; We simply search backwards through the file looking for words which
+;;; start with the same letters we are trying to complete.
+;;;
+
+(defvar cdabbrev-completions-tried nil)
+;;; "A list of all the cdabbrev completions since the last reset.")
+
+(defvar cdabbrev-current-point 0)
+;;; "The current point position the cdabbrev search is at.")
+
+(defvar cdabbrev-current-window nil)
+;;; "The current window we are looking for cdabbrevs in. T if looking in
+;;; (other-buffer), NIL if no more cdabbrevs.")
+
+(defvar cdabbrev-wrapped-p nil)
+;;; "T if the cdabbrev search has wrapped around the file.")
+
+(defvar cdabbrev-abbrev-string "")
+(defvar cdabbrev-start-point 0)
+
+;;; Test strings for cdabbrev
+;;; cdat-upcase ;;same namestring
+;;; CDAT-UPCASE ;;ok
+;;; cdat2 ;;too short
+;;; cdat-1-2-3-4 ;;ok
+;;; a-cdat-1 ;;doesn't start correctly
+;;; cdat-simple ;;ok
+
+
+(defun reset-cdabbrev (abbrev-string &optional initial-completions-tried)
+ "Resets the cdabbrev search to search for abbrev-string.
+initial-completions-tried is a list of downcased strings to ignore
+during the search."
+ (setq cdabbrev-abbrev-string abbrev-string
+ cdabbrev-completions-tried
+ (cons (downcase abbrev-string) initial-completions-tried)
+ )
+ (reset-cdabbrev-window t)
+ )
+
+(defun set-cdabbrev-buffer ()
+ ;; cdabbrev-current-window must not be NIL
+ (set-buffer (if (eq cdabbrev-current-window t)
+ (other-buffer)
+ (window-buffer cdabbrev-current-window)))
+ )
+
+
+(defun reset-cdabbrev-window (&optional initializep)
+ "Resets the cdabbrev search to search for abbrev-string.
+initial-completions-tried is a list of downcased strings to ignore
+during the search."
+ ;; Set the window
+ (cond (initializep
+ (setq cdabbrev-current-window (selected-window))
+ )
+ ((eq cdabbrev-current-window t)
+ ;; Everything has failed
+ (setq cdabbrev-current-window nil))
+ (cdabbrev-current-window
+ (setq cdabbrev-current-window (next-window cdabbrev-current-window))
+ (if (eq cdabbrev-current-window (selected-window))
+ ;; No more windows, try other buffer.
+ (setq cdabbrev-current-window t)))
+ )
+ (when cdabbrev-current-window
+ (save-excursion
+ (set-cdabbrev-buffer)
+ (setq cdabbrev-current-point (point)
+ cdabbrev-start-point cdabbrev-current-point
+ cdabbrev-stop-point
+ (if *cdabbrev-radius*
+ (max (point-min)
+ (- cdabbrev-start-point *cdabbrev-radius*))
+ (point-min))
+ cdabbrev-wrapped-p nil)
+ )))
+
+(defun next-cdabbrev ()
+ "Return the next possible cdabbrev expansion or nil if there isn't one.
+reset-cdabbrev must've been called. This is sensitive to case-fold-search."
+ ;; note that case-fold-search affects the behavior of this function
+ ;; Bug: won't pick up an expansion that starts at the top of buffer
+ (when cdabbrev-current-window
+ (let (saved-point
+ saved-syntax
+ (expansion nil)
+ downcase-expansion tried-list syntax saved-point-2)
+ (save-excursion
+ (unwind-protect
+ (progn
+ ;; Switch to current completion buffer
+ (set-cdabbrev-buffer)
+ ;; Save current buffer state
+ (setq saved-point (point)
+ saved-syntax (syntax-table))
+ ;; Restore completion state
+ (set-syntax-table cmpl-syntax-table)
+ (goto-char cdabbrev-current-point)
+ ;; Loop looking for completions
+ (while
+ ;; This code returns t if it should loop again
+ (cond
+ (;; search for the string
+ (search-backward cdabbrev-abbrev-string cdabbrev-stop-point t)
+ ;; return nil if the completion is valid
+ (not
+ (and
+ ;; does it start with a separator char ?
+ (or (= (setq syntax (char-syntax (preceding-char))) ? )
+ (and (= syntax ?w)
+ ;; symbol char to ignore at end. Are we at end ?
+ (progn
+ (setq saved-point-2 (point))
+ (forward-word -1)
+ (prog1
+ (= (char-syntax (preceding-char)) ? )
+ (goto-char saved-point-2)
+ ))))
+ ;; is the symbol long enough ?
+ (setq expansion (symbol-under-point))
+ ;; have we not tried this one before
+ (progn
+ ;; See if we've already used it
+ (setq tried-list cdabbrev-completions-tried
+ downcase-expansion (downcase expansion))
+ (while (and tried-list
+ (not (string-equal downcase-expansion
+ (car tried-list))))
+ ;; Already tried, don't choose this one
+ (setq tried-list (cdr tried-list))
+ )
+ ;; at this point tried-list will be nil if this
+ ;; expansion has not yet been tried
+ (if tried-list
+ (setq expansion nil)
+ t)
+ ))))
+ ;; search failed
+ (cdabbrev-wrapped-p
+ ;; If already wrapped, then we've failed completely
+ nil)
+ (t
+ ;; need to wrap
+ (goto-char (setq cdabbrev-current-point
+ (if *cdabbrev-radius*
+ (min (point-max) (+ cdabbrev-start-point *cdabbrev-radius*))
+ (point-max))))
+
+ (setq cdabbrev-wrapped-p t))
+ ))
+ ;; end of while loop
+ (cond (expansion
+ ;; successful
+ (setq cdabbrev-completions-tried
+ (cons downcase-expansion cdabbrev-completions-tried)
+ cdabbrev-current-point (point))))
+ )
+ (set-syntax-table saved-syntax)
+ (goto-char saved-point)
+ ))
+ ;; If no expansion, go to next window
+ (cond (expansion)
+ (t (reset-cdabbrev-window)
+ (next-cdabbrev)))
+ )))
+
+;;; The following must be eval'd in the minibuffer ::
+;;; (reset-cdabbrev "cdat")
+;;; (next-cdabbrev) --> "cdat-simple"
+;;; (next-cdabbrev) --> "cdat-1-2-3-4"
+;;; (next-cdabbrev) --> "CDAT-UPCASE"
+;;; (next-cdabbrev) --> "cdat-wrapping"
+;;; (next-cdabbrev) --> "cdat_start_sym"
+;;; (next-cdabbrev) --> nil
+;;; (next-cdabbrev) --> nil
+;;; (next-cdabbrev) --> nil
+
+;;; _cdat_start_sym
+;;; cdat-wrapping
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Completion Database
+;;;---------------------------------------------------------------------------
+
+;;; We use two storage modes for the two search types ::
+;;; 1) Prefix {cmpl-prefix-obarray} for looking up possible completions
+;;; Used by search-completion-next
+;;; the value of the symbol is nil or a cons of head and tail pointers
+;;; 2) Interning {cmpl-obarray} to see if it's in the database
+;;; Used by find-exact-completion, completion-in-database-p
+;;; The value of the symbol is the completion entry
+
+;;; bad things may happen if this length is changed due to the way
+;;; GNU implements obarrays
+(defconst cmpl-obarray-length 511)
+
+(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)
+ "An obarray used to store the downcased completion prefices.
+Each symbol is bound to a list of completion entries.")
+
+(defvar cmpl-obarray (make-vector cmpl-obarray-length 0)
+ "An obarray used to store the downcased completions.
+Each symbol is bound to a single completion entry.")
+
+;;;-----------------------------------------------
+;;; Completion Entry Structure Definition
+;;;-----------------------------------------------
+
+;;; A completion entry is a LIST of string, prefix-symbol num-uses, and
+;;; last-use-time (the time the completion was last used)
+;;; last-use-time is T if the string should be kept permanently
+;;; num-uses is incremented everytime the completion is used.
+
+;;; We chose lists because (car foo) is faster than (aref foo 0) and the
+;;; creation time is about the same.
+
+;;; READER MACROS
+
+(defmacro completion-string (completion-entry)
+ (list 'car completion-entry))
+
+(defmacro completion-num-uses (completion-entry)
+ ;; "The number of times it has used. Used to decide whether to save
+ ;; it."
+ (list 'car (list 'cdr completion-entry)))
+
+(defmacro completion-last-use-time (completion-entry)
+ ;; "The time it was last used. In hours since 1900. Used to decide
+ ;; whether to save it. T if one should always save it."
+ (list 'nth 2 completion-entry))
+
+(defmacro completion-source (completion-entry)
+ (list 'nth 3 completion-entry))
+
+;;; WRITER MACROS
+(defmacro set-completion-string (completion-entry string)
+ (list 'setcar completion-entry string))
+
+(defmacro set-completion-num-uses (completion-entry num-uses)
+ (list 'setcar (list 'cdr completion-entry) num-uses))
+
+(defmacro set-completion-last-use-time (completion-entry last-use-time)
+ (list 'setcar (list 'cdr (list 'cdr completion-entry)) last-use-time))
+
+;;; CONSTRUCTOR
+(defun make-completion (string)
+ "Returns a list of a completion entry."
+ (list (list string 0 nil current-completion-source)))
+
+;; Obsolete
+;;(defmacro cmpl-prefix-entry-symbol (completion-entry)
+;; (list 'car (list 'cdr completion-entry)))
+
+
+\f
+;;;-----------------------------------------------
+;;; Prefix symbol entry definition
+;;;-----------------------------------------------
+;;; A cons of (head . tail)
+
+;;; READER Macros
+
+(defmacro cmpl-prefix-entry-head (prefix-entry)
+ (list 'car prefix-entry))
+
+(defmacro cmpl-prefix-entry-tail (prefix-entry)
+ (list 'cdr prefix-entry))
+
+;;; WRITER Macros
+
+(defmacro set-cmpl-prefix-entry-head (prefix-entry new-head)
+ (list 'setcar prefix-entry new-head))
+
+(defmacro set-cmpl-prefix-entry-tail (prefix-entry new-tail)
+ (list 'setcdr prefix-entry new-tail))
+
+;;; Contructor
+
+(defun make-cmpl-prefix-entry (completion-entry-list)
+ "Makes a new prefix entry containing only completion-entry."
+ (cons completion-entry-list completion-entry-list))
+
+;;;-----------------------------------------------
+;;; Completion Database - Utilities
+;;;-----------------------------------------------
+
+(defun clear-all-completions ()
+ "Initializes the completion storage. All existing completions are lost."
+ (interactive)
+ (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0))
+ (setq cmpl-obarray (make-vector cmpl-obarray-length 0))
+ (cmpl-statistics-block
+ (record-clear-all-completions))
+ )
+
+(defun list-all-completions ()
+ "Returns a list of all the known completion entries."
+ (let ((return-completions nil))
+ (mapatoms 'list-all-completions-1 cmpl-prefix-obarray)
+ return-completions))
+
+(defun list-all-completions-1 (prefix-symbol)
+ (if (boundp prefix-symbol)
+ (setq return-completions
+ (append (cmpl-prefix-entry-head (symbol-value prefix-symbol))
+ return-completions))))
+
+(defun list-all-completions-by-hash-bucket ()
+ "Returns a list of lists of all the known completion entries organized by
+hash bucket."
+ (let ((return-completions nil))
+ (mapatoms 'list-all-completions-by-hash-bucket-1 cmpl-prefix-obarray)
+ return-completions))
+
+(defun list-all-completions-by-hash-bucket-1 (prefix-symbol)
+ (if (boundp prefix-symbol)
+ (setq return-completions
+ (cons (cmpl-prefix-entry-head (symbol-value prefix-symbol))
+ return-completions))))
+
+\f
+;;;-----------------------------------------------
+;;; Updating the database
+;;;-----------------------------------------------
+;;;
+;;; These are the internal functions used to update the datebase
+;;;
+;;;
+(defvar completion-to-accept nil)
+ ;;"Set to a string that is pending its acceptance."
+ ;; this checked by the top level reading functions
+
+(defvar cmpl-db-downcase-string nil)
+ ;; "Setup by find-exact-completion, etc. The given string, downcased."
+(defvar cmpl-db-symbol nil)
+ ;; "The interned symbol corresponding to cmpl-db-downcase-string.
+ ;; Set up by cmpl-db-symbol."
+(defvar cmpl-db-prefix-symbol nil)
+ ;; "The interned prefix symbol corresponding to cmpl-db-downcase-string."
+(defvar cmpl-db-entry nil)
+(defvar cmpl-db-debug-p nil
+ "Set to T if you want to debug the database.")
+
+;;; READS
+(defun find-exact-completion (string)
+ "Returns the completion entry for string or nil.
+Sets up cmpl-db-downcase-string and cmpl-db-symbol."
+ (and (boundp (setq cmpl-db-symbol
+ (intern (setq cmpl-db-downcase-string (downcase string))
+ cmpl-obarray)))
+ (symbol-value cmpl-db-symbol)
+ ))
+
+(defun find-cmpl-prefix-entry (prefix-string)
+ "Returns the prefix entry for string. Sets cmpl-db-prefix-symbol.
+Prefix-string must be exactly *completion-prefix-min-length* long
+and downcased. Sets up cmpl-db-prefix-symbol."
+ (and (boundp (setq cmpl-db-prefix-symbol
+ (intern prefix-string cmpl-prefix-obarray)))
+ (symbol-value cmpl-db-prefix-symbol)))
+
+(defvar inside-locate-completion-entry nil)
+;; used to trap lossage in silent error correction
+
+(defun locate-completion-entry (completion-entry prefix-entry)
+ "Locates the completion entry. Returns a pointer to the element
+before the completion entry or nil if the completion entry is at the head.
+Must be called after find-exact-completion."
+ (let ((prefix-list (cmpl-prefix-entry-head prefix-entry))
+ next-prefix-list
+ )
+ (cond
+ ((not (eq (car prefix-list) completion-entry))
+ ;; not already at head
+ (while (and prefix-list
+ (not (eq completion-entry
+ (car (setq next-prefix-list (cdr prefix-list)))
+ )))
+ (setq prefix-list next-prefix-list))
+ (cond (;; found
+ prefix-list)
+ ;; Didn't find it. Database is messed up.
+ (cmpl-db-debug-p
+ ;; not found, error if debug mode
+ (error "Completion entry exists but not on prefix list - %s"
+ string))
+ (inside-locate-completion-entry
+ ;; recursive error: really scrod
+ (locate-completion-db-error))
+ (t
+ ;; Patch out
+ (set cmpl-db-symbol nil)
+ ;; Retry
+ (locate-completion-entry-retry completion-entry)
+ ))))))
+
+(defun locate-completion-entry-retry (old-entry)
+ (let ((inside-locate-completion-entry t))
+ (add-completion (completion-string old-entry)
+ (completion-num-uses old-entry)
+ (completion-last-use-time old-entry))
+ (let ((cmpl-entry (find-exact-completion (completion-string old-entry)))
+ (pref-entry
+ (if cmpl-entry
+ (find-cmpl-prefix-entry
+ (substring cmpl-db-downcase-string
+ 0 *completion-prefix-min-length*))))
+ )
+ (if (and cmpl-entry pref-entry)
+ ;; try again
+ (locate-completion-entry cmpl-entry pref-entry)
+ ;; still losing
+ (locate-completion-db-error))
+ )))
+
+(defun locate-completion-db-error ()
+ ;; recursive error: really scrod
+ (error "Completion database corrupted. Try M-x clear-all-completions. Send bug report.")
+ )
+
+;;; WRITES
+(defun add-completion-to-tail-if-new (string)
+ "If the string is not in the database it is added to the end of the
+approppriate prefix list with num-uses = 0. The database is unchanged if it
+is there. string must be longer than *completion-prefix-min-length*.
+This must be very fast.
+Returns the completion entry."
+ (or (find-exact-completion string)
+ ;; not there
+ (let (;; create an entry
+ (entry (make-completion string))
+ ;; setup the prefix
+ (prefix-entry (find-cmpl-prefix-entry
+ (substring cmpl-db-downcase-string 0
+ (read-time-eval
+ *completion-prefix-min-length*))))
+ )
+ ;; The next two forms should happen as a unit (atomically) but
+ ;; no fatal errors should result if that is not the case.
+ (cond (prefix-entry
+ ;; These two should be atomic, but nothing fatal will happen
+ ;; if they're not.
+ (setcdr (cmpl-prefix-entry-tail prefix-entry) entry)
+ (set-cmpl-prefix-entry-tail prefix-entry entry))
+ (t
+ (set cmpl-db-prefix-symbol (make-cmpl-prefix-entry entry))
+ ))
+ ;; statistics
+ (cmpl-statistics-block
+ (note-added-completion))
+ ;; set symbol
+ (set cmpl-db-symbol (car entry))
+ )))
+
+(defun add-completion-to-head (string)
+ "If the string is not in the database it is added to the head of the
+approppriate prefix list. Otherwise it is moved to the head of the list.
+string must be longer than *completion-prefix-min-length*.
+Updates the saved string with the supplied string.
+This must be very fast.
+Returns the completion entry."
+ ;; Handle pending acceptance
+ (if completion-to-accept (accept-completion))
+ ;; test if already in database
+ (if (setq cmpl-db-entry (find-exact-completion string))
+ ;; found
+ (let* ((prefix-entry (find-cmpl-prefix-entry
+ (substring cmpl-db-downcase-string 0
+ (read-time-eval
+ *completion-prefix-min-length*))))
+ (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))
+ (cmpl-ptr (cdr splice-ptr))
+ )
+ ;; update entry
+ (set-completion-string cmpl-db-entry string)
+ ;; move to head (if necessary)
+ (cond (splice-ptr
+ ;; These should all execute atomically but it is not fatal if
+ ;; they don't.
+ ;; splice it out
+ (or (setcdr splice-ptr (cdr cmpl-ptr))
+ ;; fix up tail if necessary
+ (set-cmpl-prefix-entry-tail prefix-entry splice-ptr))
+ ;; splice in at head
+ (setcdr cmpl-ptr (cmpl-prefix-entry-head prefix-entry))
+ (set-cmpl-prefix-entry-head prefix-entry cmpl-ptr)
+ ))
+ cmpl-db-entry)
+ ;; not there
+ (let (;; create an entry
+ (entry (make-completion string))
+ ;; setup the prefix
+ (prefix-entry (find-cmpl-prefix-entry
+ (substring cmpl-db-downcase-string 0
+ (read-time-eval
+ *completion-prefix-min-length*))))
+ )
+ (cond (prefix-entry
+ ;; Splice in at head
+ (setcdr entry (cmpl-prefix-entry-head prefix-entry))
+ (set-cmpl-prefix-entry-head prefix-entry entry))
+ (t
+ ;; Start new prefix entry
+ (set cmpl-db-prefix-symbol (make-cmpl-prefix-entry entry))
+ ))
+ ;; statistics
+ (cmpl-statistics-block
+ (note-added-completion))
+ ;; Add it to the symbol
+ (set cmpl-db-symbol (car entry))
+ )))
+
+(defun delete-completion (string)
+ "Deletes the completion from the database. string must be longer than
+*completion-prefix-min-length*."
+ ;; Handle pending acceptance
+ (if completion-to-accept (accept-completion))
+ (if (setq cmpl-db-entry (find-exact-completion string))
+ ;; found
+ (let* ((prefix-entry (find-cmpl-prefix-entry
+ (substring cmpl-db-downcase-string 0
+ (read-time-eval
+ *completion-prefix-min-length*))))
+ (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))
+ )
+ ;; delete symbol reference
+ (set cmpl-db-symbol nil)
+ ;; remove from prefix list
+ (cond (splice-ptr
+ ;; not at head
+ (or (setcdr splice-ptr (cdr (cdr splice-ptr)))
+ ;; fix up tail if necessary
+ (set-cmpl-prefix-entry-tail prefix-entry splice-ptr))
+ )
+ (t
+ ;; at head
+ (or (set-cmpl-prefix-entry-head
+ prefix-entry (cdr (cmpl-prefix-entry-head prefix-entry)))
+ ;; List is now empty
+ (set cmpl-db-prefix-symbol nil))
+ ))
+ (cmpl-statistics-block
+ (note-completion-deleted))
+ )
+ (error "Unknown completion: %s. Couldn't delete it." string)
+ ))
+
+;;; Tests --
+;;; - Add and Find -
+;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
+;;; (find-exact-completion "banana") --> ("banana" 0 nil 0)
+;;; (find-exact-completion "bana") --> nil
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
+;;; (add-completion-to-head "banish") --> ("banish" 0 nil 0)
+;;; (find-exact-completion "banish") --> ("banish" 0 nil 0)
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
+;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
+;;;
+;;; - Deleting -
+;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
+;;; (delete-completion "banner")
+;;; (find-exact-completion "banner") --> nil
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
+;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
+;;; (delete-completion "banana")
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
+;;; (delete-completion "banner")
+;;; (delete-completion "banish")
+;;; (find-cmpl-prefix-entry "ban") --> nil
+;;; (delete-completion "banner") --> error
+;;;
+;;; - Tail -
+;;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0)
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
+;;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0)
+;;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...))
+;;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...))
+;;;
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Database Update :: Interface level routines
+;;;---------------------------------------------------------------------------
+;;;
+;;; These lie on top of the database ref. functions but below the standard
+;;; user interface level
+
+
+(defun interactive-completion-string-reader (prompt)
+ (let* ((default (symbol-under-or-before-point))
+ (new-prompt
+ (if default
+ (format "%s: (default: %s) " prompt default)
+ (format "%s: " prompt))
+ )
+ (read (completing-read new-prompt cmpl-obarray))
+ )
+ (if (zerop (length read)) (setq read (or default "")))
+ (list read)
+ ))
+
+(defun check-completion-length (string)
+ (if (< (length string) *completion-min-length*)
+ (error "The string \"%s\" is too short to be saved as a completion."
+ string)
+ (list string)))
+
+(defun add-completion (string &optional num-uses last-use-time)
+ "If the string is not there, it is added to the head of the completion list.
+Otherwise, it is moved to the head of the list.
+The completion is altered appropriately if num-uses and/or last-use-time is
+specified."
+ (interactive (interactive-completion-string-reader "Completion to add"))
+ (check-completion-length string)
+ (let* ((current-completion-source (if (interactive-p)
+ cmpl-source-interactive
+ current-completion-source))
+ (entry (add-completion-to-head string)))
+
+ (if num-uses (set-completion-num-uses entry num-uses))
+ (if last-use-time
+ (set-completion-last-use-time entry last-use-time))
+ ))
+
+(defun add-permanent-completion (string)
+ "Adds string if it isn't already there and and makes it a permanent string."
+ (interactive
+ (interactive-completion-string-reader "Completion to add permanently"))
+ (let ((current-completion-source (if (interactive-p)
+ cmpl-source-interactive
+ current-completion-source))
+ )
+ (add-completion string nil t)
+ ))
+
+(defun kill-completion (string)
+ (interactive (interactive-completion-string-reader "Completion to kill"))
+ (check-completion-length string)
+ (delete-completion string)
+ )
+
+(defun accept-completion ()
+ "Accepts the pending completion in completion-to-accept.
+This bumps num-uses. Called by add-completion-to-head and
+completion-search-reset."
+ (let ((string completion-to-accept)
+ ;; if this is added afresh here, then it must be a cdabbrev
+ (current-completion-source cmpl-source-cdabbrev)
+ entry
+ )
+ (setq completion-to-accept nil)
+ (setq entry (add-completion-to-head string))
+ (set-completion-num-uses entry (1+ (completion-num-uses entry)))
+ (setq cmpl-completions-accepted-p t)
+ ))
+
+(defun use-completion-under-point ()
+ "Call this to add the completion symbol underneath the point into
+the completion buffer."
+ (let ((string (and *completep* (symbol-under-point)))
+ (current-completion-source cmpl-source-cursor-moves))
+ (if string (add-completion-to-head string))))
+
+(defun use-completion-before-point ()
+ "Call this to add the completion symbol before point into
+the completion buffer."
+ (let ((string (and *completep* (symbol-before-point)))
+ (current-completion-source cmpl-source-cursor-moves))
+ (if string (add-completion-to-head string))))
+
+(defun use-completion-under-or-before-point ()
+ "Call this to add the completion symbol before point into
+the completion buffer."
+ (let ((string (and *completep* (symbol-under-or-before-point)))
+ (current-completion-source cmpl-source-cursor-moves))
+ (if string (add-completion-to-head string))))
+
+(defun use-completion-before-separator ()
+ "Call this to add the completion symbol before point into
+the completion buffer. Completions added this way will automatically be
+saved if *separator-character-uses-completion-p* is non-nil."
+ (let ((string (and *completep* (symbol-before-point)))
+ (current-completion-source cmpl-source-separator)
+ entry)
+ (cmpl-statistics-block
+ (note-separator-character string)
+ )
+ (cond (string
+ (setq entry (add-completion-to-head string))
+ (when (and *separator-character-uses-completion-p*
+ (zerop (completion-num-uses entry)))
+ (set-completion-num-uses entry 1)
+ (setq cmpl-completions-accepted-p t)
+ )))
+ ))
+
+;;; Tests --
+;;; - Add and Find -
+;;; (add-completion "banana" 5 10)
+;;; (find-exact-completion "banana") --> ("banana" 5 10 0)
+;;; (add-completion "banana" 6)
+;;; (find-exact-completion "banana") --> ("banana" 6 10 0)
+;;; (add-completion "banish")
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
+;;;
+;;; - Accepting -
+;;; (setq completion-to-accept "banana")
+;;; (accept-completion)
+;;; (find-exact-completion "banana") --> ("banana" 7 10)
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
+;;; (setq completion-to-accept "banish")
+;;; (add-completion "banner")
+;;; (car (find-cmpl-prefix-entry "ban"))
+;;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...))
+;;;
+;;; - Deleting -
+;;; (kill-completion "banish")
+;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...))
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Searching the database
+;;;---------------------------------------------------------------------------
+;;; Functions outside this block must call completion-search-reset followed
+;;; by calls to completion-search-next or completion-search-peek
+;;;
+
+;;; Status variables
+;; Commented out to improve loading speed
+(defvar cmpl-test-string "")
+;; "The current string used by completion-search-next."
+(defvar cmpl-test-regexp "")
+;; "The current regexp used by completion-search-next.
+;; (derived from cmpl-test-string)"
+(defvar cmpl-last-index 0)
+;; "The last index that completion-search-next was called with."
+(defvar cmpl-cdabbrev-reset-p nil)
+;; "Set to t when cdabbrevs have been reset."
+(defvar cmpl-next-possibilities nil)
+;; "A pointer to the element BEFORE the next set of possible completions.
+;; cadr of this is the cmpl-next-possibility"
+(defvar cmpl-starting-possibilities nil)
+;; "The initial list of starting possibilities."
+(defvar cmpl-next-possibility nil)
+;; "The cached next possibility."
+(defvar cmpl-tried-list nil)
+;; "A downcased list of all the completions we have tried."
+
+
+(defun completion-search-reset (string)
+ "Given a string, sets up the get-completion and completion-search-next functions.
+String must be longer than *completion-prefix-min-length*."
+ (if completion-to-accept (accept-completion))
+ (setq cmpl-starting-possibilities
+ (cmpl-prefix-entry-head
+ (find-cmpl-prefix-entry (downcase (substring string 0 3))))
+ cmpl-test-string string
+ cmpl-test-regexp (concat (regexp-quote string) "."))
+ (completion-search-reset-1)
+ )
+
+(defun completion-search-reset-1 ()
+ (setq cmpl-next-possibilities cmpl-starting-possibilities
+ cmpl-next-possibility nil
+ cmpl-cdabbrev-reset-p nil
+ cmpl-last-index -1
+ cmpl-tried-list nil
+ ))
+
+(defun completion-search-next (index)
+ "Returns the next completion entry. If index is out of sequence it resets
+and starts from the top. If there are no more entries it tries cdabbrev and
+returns only a string."
+ (cond
+ ((= index (setq cmpl-last-index (1+ cmpl-last-index)))
+ (completion-search-peek t))
+ ((minusp index)
+ (completion-search-reset-1)
+ (setq cmpl-last-index index)
+ ;; reverse the possibilities list
+ (setq cmpl-next-possibilities (reverse cmpl-starting-possibilities))
+ ;; do a "normal" search
+ (while (and (completion-search-peek nil)
+ (minusp (setq index (1+ index))))
+ (setq cmpl-next-possibility nil)
+ )
+ (cond ((not cmpl-next-possibilities))
+ ;; If no more possibilities, leave it that way
+ ((= -1 cmpl-last-index)
+ ;; next completion is at index 0. reset next-possibility list
+ ;; to start at beginning
+ (setq cmpl-next-possibilities cmpl-starting-possibilities))
+ (t
+ ;; otherwise point to one before current
+ (setq cmpl-next-possibilities
+ (nthcdr (- (length cmpl-starting-possibilities)
+ (length cmpl-next-possibilities))
+ cmpl-starting-possibilities))
+ )))
+ (t
+ ;; non-negative index, reset and search
+ ;;(prin1 'reset)
+ (completion-search-reset-1)
+ (setq cmpl-last-index index)
+ (while (and (completion-search-peek t)
+ (not (minusp (setq index (1- index)))))
+ (setq cmpl-next-possibility nil)
+ ))
+ )
+ (prog1
+ cmpl-next-possibility
+ (setq cmpl-next-possibility nil)
+ ))
+
+
+(defun completion-search-peek (use-cdabbrev)
+ "Returns the next completion entry without actually moving the pointers.
+Calling this again or calling completion-search-next will result in the same
+string being returned. Depends on case-fold-search.
+If there are no more entries it tries cdabbrev and then returns only a string."
+ (cond
+ ;; return the cached value if we have it
+ (cmpl-next-possibility)
+ ((and cmpl-next-possibilities
+ ;; still a few possibilities left
+ (progn
+ (while
+ (and (not (eq 0 (string-match cmpl-test-regexp
+ (completion-string (car cmpl-next-possibilities)))))
+ (setq cmpl-next-possibilities (cdr cmpl-next-possibilities))
+ ))
+ cmpl-next-possibilities
+ ))
+ ;; successful match
+ (setq cmpl-next-possibility (car cmpl-next-possibilities)
+ cmpl-tried-list (cons (downcase (completion-string cmpl-next-possibility))
+ cmpl-tried-list)
+ cmpl-next-possibilities (cdr cmpl-next-possibilities)
+ )
+ cmpl-next-possibility)
+ (use-cdabbrev
+ ;; unsuccessful, use cdabbrev
+ (cond ((not cmpl-cdabbrev-reset-p)
+ (reset-cdabbrev cmpl-test-string cmpl-tried-list)
+ (setq cmpl-cdabbrev-reset-p t)
+ ))
+ (setq cmpl-next-possibility (next-cdabbrev))
+ )
+ ;; Completely unsuccessful, return nil
+ ))
+
+;;; Tests --
+;;; - Add and Find -
+;;; (add-completion "banana")
+;;; (completion-search-reset "ban")
+;;; (completion-search-next 0) --> "banana"
+;;;
+;;; - Discrimination -
+;;; (add-completion "cumberland")
+;;; (add-completion "cumberbund")
+;;; cumbering
+;;; (completion-search-reset "cumb")
+;;; (completion-search-peek t) --> "cumberbund"
+;;; (completion-search-next 0) --> "cumberbund"
+;;; (completion-search-peek t) --> "cumberland"
+;;; (completion-search-next 1) --> "cumberland"
+;;; (completion-search-peek nil) --> nil
+;;; (completion-search-next 2) --> "cumbering" {cdabbrev}
+;;; (completion-search-next 3) --> nil or "cumming"{depends on context}
+;;; (completion-search-next 1) --> "cumberland"
+;;; (completion-search-peek t) --> "cumbering" {cdabbrev}
+;;;
+;;; - Accepting -
+;;; (completion-search-next 1) --> "cumberland"
+;;; (setq completion-to-accept "cumberland")
+;;; (completion-search-reset "foo")
+;;; (completion-search-reset "cum")
+;;; (completion-search-next 0) --> "cumberland"
+;;;
+;;; - Deleting -
+;;; (kill-completion "cumberland")
+;;; cummings
+;;; (completion-search-reset "cum")
+;;; (completion-search-next 0) --> "cumberbund"
+;;; (completion-search-next 1) --> "cummings"
+;;;
+;;; - Ignoring Capitalization -
+;;; (completion-search-reset "CuMb")
+;;; (completion-search-next 0) --> "cumberbund"
+
+
+\f
+;;;-----------------------------------------------
+;;; COMPLETE
+;;;-----------------------------------------------
+
+(defun completion-mode ()
+ "Toggles whether or not new words are added to the database."
+ (interactive)
+ (setq *completep* (not *completep*))
+ (message "Completion mode is now %s." (if *completep* "ON" "OFF"))
+ )
+
+(defvar cmpl-current-index 0)
+(defvar cmpl-original-string nil)
+(defvar cmpl-last-insert-location -1)
+(defvar cmpl-leave-point-at-start nil)
+
+(defun complete (&optional arg)
+ "Inserts a completion at point.
+Point is left at end. Consective calls rotate through all possibilities.
+Prefix args ::
+ control-u :: leave the point at the beginning of the completion rather
+ than at the end.
+ a number :: rotate through the possible completions by that amount
+ `-' :: same as -1 (insert previous completion)
+ {See the comments at the top of completion.el for more info.}
+"
+ (interactive "*p")
+ ;;; Set up variables
+ (cond ((eq last-command this-command)
+ ;; Undo last one
+ (delete-region cmpl-last-insert-location (point))
+ ;; get next completion
+ (setq cmpl-current-index (+ cmpl-current-index (or arg 1)))
+ )
+ (t
+ (if (not cmpl-initialized-p)
+ (initialize-completions)) ;; make sure everything's loaded
+ (cond ((consp current-prefix-arg) ;; control-u
+ (setq arg 0)
+ (setq cmpl-leave-point-at-start t)
+ )
+ (t
+ (setq cmpl-leave-point-at-start nil)
+ ))
+ ;; get string
+ (setq cmpl-original-string (symbol-before-point-for-complete))
+ (cond ((not cmpl-original-string)
+ (setq this-command 'failed-complete)
+ (error "To complete, the point must be after a symbol at least %d character long."
+ *completion-prefix-min-length*)))
+ ;; get index
+ (setq cmpl-current-index (if current-prefix-arg arg 0))
+ ;; statistics
+ (cmpl-statistics-block
+ (note-complete-entered-afresh cmpl-original-string))
+ ;; reset database
+ (completion-search-reset cmpl-original-string)
+ ;; erase what we've got
+ (delete-region cmpl-symbol-start cmpl-symbol-end)
+ ))
+
+ ;; point is at the point to insert the new symbol
+ ;; Get the next completion
+ (let* ((print-status-p
+ (and (>= (cmpl19-baud-rate) *print-next-completion-speed-threshold*)
+ (not (minibuffer-window-selected-p))))
+ (insert-point (point))
+ (entry (completion-search-next cmpl-current-index))
+ string
+ )
+ ;; entry is either a completion entry or a string (if cdabbrev)
+
+ ;; If found, insert
+ (cond (entry
+ ;; Setup for proper case
+ (setq string (if (stringp entry)
+ entry (completion-string entry)))
+ (setq string (cmpl-merge-string-cases
+ string cmpl-original-string))
+ ;; insert
+ (insert string)
+ ;; accept it
+ (setq completion-to-accept string)
+ ;; fixup and cache point
+ (cond (cmpl-leave-point-at-start
+ (setq cmpl-last-insert-location (point))
+ (goto-char insert-point))
+ (t;; point at end,
+ (setq cmpl-last-insert-location insert-point))
+ )
+ ;; statistics
+ (cmpl-statistics-block
+ (note-complete-inserted entry cmpl-current-index))
+ ;; Done ! cmpl-stat-complete-successful
+ ;;display the next completion
+ (cond
+ ((and print-status-p
+ ;; This updates the display and only prints if there
+ ;; is no typeahead
+ (cmpl19-sit-for 0)
+ (setq entry
+ (completion-search-peek
+ *print-next-completion-does-cdabbrev-search-p*)))
+ (setq string (if (stringp entry)
+ entry (completion-string entry)))
+ (setq string (cmpl-merge-string-cases
+ string cmpl-original-string))
+ (message "Next completion: %s" string)
+ ))
+ )
+ (t;; none found, insert old
+ (insert cmpl-original-string)
+ ;; Don't accept completions
+ (setq completion-to-accept nil)
+ ;; print message
+ (if (and print-status-p (cmpl19-sit-for 0))
+ (message "No %scompletions."
+ (if (eq this-command last-command) "more " "")))
+ ;; statistics
+ (cmpl-statistics-block
+ (record-complete-failed cmpl-current-index))
+ ;; Pretend that we were never here
+ (setq this-command 'failed-complete)
+ ))))
+
+;;;-----------------------------------------------
+;;; "Complete" Key Keybindings
+;;;-----------------------------------------------
+
+;;; Complete key definition
+;;; These define c-return and meta-return
+;;; In any case you really want to bind this to a single keystroke
+(if (fboundp 'key-for-others-chord)
+ (condition-case e
+ ;; this can fail if some of the prefix chars. are already used
+ ;; as commands (this happens on wyses)
+ (global-set-key (key-for-others-chord "return" '(control)) 'complete)
+ (error)
+ ))
+(if (fboundp 'gmacs-keycode)
+ (global-set-key (gmacs-keycode "return" '(control)) 'complete)
+ )
+(global-set-key "\M-\r" 'complete)
+
+;;; Tests -
+;;; (add-completion "cumberland")
+;;; (add-completion "cumberbund")
+;;; cum
+;;; Cumber
+;;; cumbering
+;;; cumb
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Parsing definitions from files into the database
+;;;---------------------------------------------------------------------------
+
+;;;-----------------------------------------------
+;;; Top Level functions ::
+;;;-----------------------------------------------
+
+;;; User interface
+(defun add-completions-from-file (file)
+ "Parses all the definition names from a Lisp mode file and adds them to the
+completion database."
+ (interactive "fFile: ")
+ (setq file (if (fboundp 'expand-file-name-defaulting)
+ (expand-file-name-defaulting file)
+ (expand-file-name file)))
+ (let* ((buffer (get-file-buffer file))
+ (buffer-already-there-p buffer)
+ )
+ (when (not buffer-already-there-p)
+ (let ((*modes-for-completion-find-file-hook* nil))
+ (setq buffer (find-file-noselect file))
+ ))
+ (unwind-protect
+ (save-excursion
+ (set-buffer buffer)
+ (add-completions-from-buffer)
+ )
+ (when (not buffer-already-there-p)
+ (kill-buffer buffer))
+ )))
+
+(defun add-completions-from-buffer ()
+ (interactive)
+ (let ((current-completion-source cmpl-source-file-parsing)
+ (start-num
+ (cmpl-statistics-block
+ (aref completion-add-count-vector cmpl-source-file-parsing)))
+ mode
+ )
+ (cond ((memq major-mode '(emacs-lisp-mode lisp-mode))
+ (add-completions-from-lisp-buffer)
+ (setq mode 'lisp)
+ )
+ ((memq major-mode '(c-mode))
+ (add-completions-from-c-buffer)
+ (setq mode 'c)
+ )
+ (t
+ (error "Do not know how to parse completions in %s buffers."
+ major-mode)
+ ))
+ (cmpl-statistics-block
+ (record-cmpl-parse-file
+ mode (point-max)
+ (- (aref completion-add-count-vector cmpl-source-file-parsing)
+ start-num)))
+ ))
+
+;;; Find file hook
+(defun cmpl-find-file-hook ()
+ (cond (*completep*
+ (cond ((and (memq major-mode '(emacs-lisp-mode lisp-mode))
+ (memq 'lisp *modes-for-completion-find-file-hook*)
+ )
+ (add-completions-from-buffer))
+ ((and (memq major-mode '(c-mode))
+ (memq 'c *modes-for-completion-find-file-hook*)
+ )
+ (add-completions-from-buffer)
+ )))
+ ))
+
+(pushnew 'cmpl-find-file-hook find-file-hooks)
+
+;;;-----------------------------------------------
+;;; Tags Table Completions
+;;;-----------------------------------------------
+
+(defun add-completions-from-tags-table ()
+ ;; Inspired by eero@media-lab.media.mit.edu
+ "Add completions from the current tags-table-buffer."
+ (interactive)
+ (visit-tags-table-buffer) ;this will prompt if no tags-table
+ (save-excursion
+ (goto-char (point-min))
+ (let (string)
+ (condition-case e
+ (while t
+ (search-forward "\177")
+ (backward-char 3)
+ (and (setq string (symbol-under-point))
+ (add-completion-to-tail-if-new string))
+ (forward-char 3)
+ )
+ (search-failed)
+ ))))
+
+\f
+;;;-----------------------------------------------
+;;; Lisp File completion parsing
+;;;-----------------------------------------------
+;;; This merely looks for phrases beginning with (def.... or
+;;; (package:def ... and takes the next word.
+;;;
+;;; We tried using forward-lines and explicit searches but the regexp technique
+;;; was faster. (About 100K characters per second)
+;;;
+(defconst *lisp-def-regexp*
+ "\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
+ "A regexp that searches for lisp definition form."
+ )
+
+;;; Tests -
+;;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8
+;;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9
+;;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10
+;;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9
+
+(defun add-completions-from-lisp-buffer ()
+ "Parses all the definition names from a Lisp mode buffer and adds them to
+the completion database."
+ ;;; Benchmarks
+ ;;; Sun-3/280 - 1500 to 3000 lines of lisp code per second
+ (let (string)
+ (save-excursion
+ (goto-char (point-min))
+ (condition-case e
+ (while t
+ (re-search-forward *lisp-def-regexp*)
+ (and (setq string (symbol-under-point))
+ (add-completion-to-tail-if-new string))
+ )
+ (search-failed)
+ ))))
+
+\f
+;;;-----------------------------------------------
+;;; C file completion parsing
+;;;-----------------------------------------------
+;;; C :
+;;; Looks for #define or [<storage class>] [<type>] <name>{,<name>}
+;;; or structure, array or pointer defs.
+;;; It gets most of the definition names.
+;;;
+;;; As you might suspect by now, we use some symbol table hackery
+;;;
+;;; Symbol separator chars (have whitespace syntax) --> , ; * = (
+;;; Opening char --> [ {
+;;; Closing char --> ] }
+;;; openning and closing must be skipped over
+;;; Whitespace chars (have symbol syntax)
+;;; Everything else has word syntax
+
+(defun make-c-def-completion-syntax-table ()
+ (let ((table (make-vector 256 0))
+ (whitespace-chars '(? ?\n ?\t ?\f ?\v ?\r))
+ ;; unforunately the ?( causes the parens to appear unbalanced
+ (separator-chars '(?, ?* ?= ?\( ?\;
+ ))
+ )
+ ;; default syntax is whitespace
+ (dotimes (i 256)
+ (modify-syntax-entry i "w" table))
+ (dolist (char whitespace-chars)
+ (modify-syntax-entry char "_" table))
+ (dolist (char separator-chars)
+ (modify-syntax-entry char " " table))
+ (modify-syntax-entry ?\[ "(]" table)
+ (modify-syntax-entry ?\{ "(}" table)
+ (modify-syntax-entry ?\] ")[" table)
+ (modify-syntax-entry ?\} "){" table)
+ table))
+
+(defconst cmpl-c-def-syntax-table (make-c-def-completion-syntax-table))
+
+;;; Regexps
+(defconst *c-def-regexp*
+ ;; This stops on lines with possible definitions
+ "\n[_a-zA-Z#]"
+ ;; This stops after the symbol to add.
+ ;;"\n\\(#define\\s +.\\|\\(\\(\\w\\|\\s_\\)+\\b\\s *\\)+[(;,[*{=]\\)"
+ ;; This stops before the symbol to add. {Test cases in parens. below}
+ ;;"\n\\(\\(\\w\\|\\s_\\)+\\s *(\\|\\(\\(#define\\|auto\\|extern\\|register\\|static\\|int\\|long\\|short\\|unsigned\\|char\\|void\\|float\\|double\\|enum\\|struct\\|union\\|typedef\\)\\s +\\)+\\)"
+ ;; this simple version picks up too much extraneous stuff
+ ;; "\n\\(\\w\\|\\s_\\|#\\)\\B"
+ "A regexp that searches for a definition form."
+ )
+;
+;(defconst *c-cont-regexp*
+; "\\(\\w\\|\\s_\\)+\\b\\s *\\({\\|\\(\\[[0-9\t ]*\\]\\s *\\)*,\\(*\\|\\s \\)*\\b\\)"
+; "This regexp should be used in a looking-at to parse for lists of variables.")
+;
+;(defconst *c-struct-regexp*
+; "\\(*\\|\\s \\)*\\b"
+; "This regexp should be used to test whether a symbol follows a structure definition.")
+
+;(defun test-c-def-regexp (regexp string)
+; (and (eq 0 (string-match regexp string)) (match-end 0))
+; )
+
+;;; Tests -
+;;; (test-c-def-regexp *c-def-regexp* "\n#define foo") -> 10 (9)
+;;; (test-c-def-regexp *c-def-regexp* "\nfoo (x, y) {") -> 6 (6)
+;;; (test-c-def-regexp *c-def-regexp* "\nint foo (x, y)") -> 10 (5)
+;;; (test-c-def-regexp *c-def-regexp* "\n int foo (x, y)") -> nil
+;;; (test-c-def-regexp *c-cont-regexp* "oo, bar") -> 4
+;;; (test-c-def-regexp *c-cont-regexp* "oo, *bar") -> 5
+;;; (test-c-def-regexp *c-cont-regexp* "a [5][6], bar") -> 10
+;;; (test-c-def-regexp *c-cont-regexp* "oo(x,y)") -> nil
+;;; (test-c-def-regexp *c-cont-regexp* "a [6] ,\t bar") -> 9
+;;; (test-c-def-regexp *c-cont-regexp* "oo {trout =1} my_carp;") -> 14
+;;; (test-c-def-regexp *c-cont-regexp* "truct_p complex foon") -> nil
+
+(defun add-completions-from-c-buffer ()
+ "Parses all the definition names from a C mode buffer and adds them to the
+completion database."
+ ;; Benchmark --
+ ;; Sun 3/280-- 1250 lines/sec.
+
+ (let (string next-point char
+ (saved-syntax (syntax-table))
+ )
+ (save-excursion
+ (goto-char (point-min))
+ (catch 'finish-add-completions
+ (unwind-protect
+ (while t
+ ;; we loop here only when scan-sexps fails
+ ;; (i.e. unbalance exps.)
+ (set-syntax-table cmpl-c-def-syntax-table)
+ (condition-case e
+ (while t
+ (re-search-forward *c-def-regexp*)
+ (cond
+ ((= (preceding-char) ?#)
+ ;; preprocessor macro, see if it's one we handle
+ (setq string (buffer-substring (point) (+ (point) 6)))
+ (cond ((or (string-equal string "define")
+ (string-equal string "ifdef ")
+ )
+ ;; skip forward over definition symbol
+ ;; and add it to database
+ (and (forward-word 2)
+ (setq string (symbol-before-point))
+ ;;(push string foo)
+ (add-completion-to-tail-if-new string)
+ ))))
+ (t
+ ;; C definition
+ (setq next-point (point))
+ (while (and
+ next-point
+ ;; scan to next separator char.
+ (setq next-point (scan-sexps next-point 1))
+ )
+ ;; position the point on the word we want to add
+ (goto-char next-point)
+ (while (= (setq char (following-char)) ?*)
+ ;; handle pointer ref
+ ;; move to next separator char.
+ (goto-char
+ (setq next-point (scan-sexps (point) 1)))
+ )
+ (forward-word -1)
+ ;; add to database
+ (if (setq string (symbol-under-point))
+ ;; (push string foo)
+ (add-completion-to-tail-if-new string)
+ ;; Local TMC hack (useful for parsing paris.h)
+ (if (and (looking-at "_AP") ;; "ansi prototype"
+ (progn
+ (forward-word -1)
+ (setq string
+ (symbol-under-point))
+ ))
+ (add-completion-to-tail-if-new string)
+ )
+ )
+ ;; go to next
+ (goto-char next-point)
+ ;; (push (format "%c" (following-char)) foo)
+ (if (= (char-syntax char) ?\()
+ ;; if on an opening delimiter, go to end
+ (while (= (char-syntax char) ?\()
+ (setq next-point (scan-sexps next-point 1)
+ char (char-after next-point))
+ )
+ (or (= char ?,)
+ ;; Current char is an end char.
+ (setq next-point nil)
+ ))
+ ))))
+ (search-failed ;;done
+ (throw 'finish-add-completions t)
+ )
+ (error
+ ;; Check for failure in scan-sexps
+ (if (or (string-equal (second e)
+ "Containing expression ends prematurely")
+ (string-equal (second e) "Unbalanced parentheses"))
+ ;; unbalanced paren., keep going
+ ;;(ding)
+ (forward-line 1)
+ (message "Error parsing C buffer for completions. Please bug report.")
+ (throw 'finish-add-completions t)
+ ))
+ ))
+ (set-syntax-table saved-syntax)
+ )))))
+
+\f
+;;;---------------------------------------------------------------------------
+;;; Init files
+;;;---------------------------------------------------------------------------
+
+(defun kill-emacs-save-completions ()
+ "The version of save-completions-to-file called at kill-emacs
+time."
+ (when (and *save-completions-p* *completep* cmpl-initialized-p)
+ (cond
+ ((not cmpl-completions-accepted-p)
+ (message "Completions database has not changed - not writing."))
+ (t
+ (save-completions-to-file)
+ ))
+ ))
+
+(defconst saved-cmpl-file-header
+ ";;; Completion Initialization file.
+;;; Version = %s
+;;; Format is (<string> . <last-use-time>)
+;;; <string> is the completion
+;;; <last-use-time> is the time the completion was last used
+;;; If it is t, the completion will never be pruned from the file.
+;;; Otherwise it is in hours since 1900.
+\n")
+
+(defun completion-backup-filename (filename)
+ (concat filename ".BAK"))
+
+(defun save-completions-to-file (&optional filename)
+ "Saves a completion init file. If file is not specified,
+ then *saved-completions-filename* is used."
+ (interactive)
+ (setq filename (expand-file-name (or filename *saved-completions-filename*)))
+ (when (file-writable-p filename)
+ (if (not cmpl-initialized-p)
+ (initialize-completions));; make sure everything's loaded
+ (message "Saving completions to file %s" filename)
+
+ (let* ((trim-versions-without-asking t)
+ (kept-old-versions 0)
+ (kept-new-versions *completion-file-versions-kept*)
+ last-use-time
+ (current-time (cmpl-hours-since-1900))
+ (total-in-db 0)
+ (total-perm 0)
+ (total-saved 0)
+ (backup-filename (completion-backup-filename filename))
+ )
+
+ (save-excursion
+ (get-buffer-create " *completion-save-buffer*")
+ (set-buffer " *completion-save-buffer*")
+ (setq buffer-file-name filename)
+
+ (when (not (verify-visited-file-modtime (current-buffer)))
+ ;; file has changed on disk. Bring us up-to-date
+ (message "Completion file has changed. Merging. . .")
+ (load-completions-from-file filename t)
+ (message "Merging finished. Saving completions to file %s" filename)
+ )
+
+ ;; prepare the buffer to be modified
+ (clear-visited-file-modtime)
+ (erase-buffer)
+ ;; (/ 1 0)
+ (insert (format saved-cmpl-file-header *completion-version*))
+ (dolist (completion (list-all-completions))
+ (setq total-in-db (1+ total-in-db))
+ (setq last-use-time (completion-last-use-time completion))
+ ;; Update num uses and maybe write completion to a file
+ (cond ((or;; Write to file if
+ ;; permanent
+ (and (eq last-use-time t)
+ (setq total-perm (1+ total-perm)))
+ ;; or if
+ (if (plusp (completion-num-uses completion))
+ ;; it's been used
+ (setq last-use-time current-time)
+ ;; or it was saved before and
+ (and last-use-time
+ ;; *saved-completion-retention-time* is nil
+ (or (not *saved-completion-retention-time*)
+ ;; or time since last use is < ...retention-time*
+ (< (- current-time last-use-time)
+ *saved-completion-retention-time*))
+ )))
+ ;; write to file
+ (setq total-saved (1+ total-saved))
+ (insert (prin1-to-string (cons (completion-string completion)
+ last-use-time)) "\n")
+ )))
+
+ ;; write the buffer
+ (condition-case e
+ (let ((file-exists-p (file-exists-p filename)))
+ (when file-exists-p
+ ;; If file exists . . .
+ ;; Save a backup(so GNU doesn't screw us when we're out of disk)
+ ;; (GNU leaves a 0 length file if it gets a disk full error!)
+
+ ;; If backup doesn't exit, Rename current to backup
+ ;; {If backup exists the primary file is probably messed up}
+ (unless (file-exists-p backup-filename)
+ (rename-file filename backup-filename))
+ ;; Copy the backup back to the current name
+ ;; (so versioning works)
+ (copy-file backup-filename filename t)
+ )
+ ;; Save it
+ (save-buffer)
+ (when file-exists-p
+ ;; If successful, remove backup
+ (delete-file backup-filename)
+ ))
+ (error
+ (set-buffer-modified-p nil)
+ (message "Couldn't save completion file %s." filename)
+ ))
+ ;; Reset accepted-p flag
+ (setq cmpl-completions-accepted-p nil)
+ )
+ (cmpl-statistics-block
+ (record-save-completions total-in-db total-perm total-saved))
+ )))
+
+(defun autosave-completions ()
+ (when (and *save-completions-p* *completep* cmpl-initialized-p
+ *completion-auto-save-period*
+ (> cmpl-emacs-idle-time *completion-auto-save-period*)
+ cmpl-completions-accepted-p)
+ (save-completions-to-file)
+ ))
+
+(pushnew 'autosave-completions cmpl-emacs-idle-time-hooks)
+
+(defun load-completions-from-file (&optional filename no-message-p)
+ "loads a completion init file. If file is not specified,
+ then *saved-completions-filename* is used"
+ (interactive)
+ (setq filename (expand-file-name (or filename *saved-completions-filename*)))
+ (let* ((backup-filename (completion-backup-filename filename))
+ (backup-readable-p (file-readable-p backup-filename))
+ )
+ (when backup-readable-p (setq filename backup-filename))
+ (when (file-readable-p filename)
+ (if (not no-message-p)
+ (message "Loading completions from %sfile %s . . ."
+ (if backup-readable-p "backup " "") filename))
+ (save-excursion
+ (get-buffer-create " *completion-save-buffer*")
+ (set-buffer " *completion-save-buffer*")
+ (setq buffer-file-name filename)
+ ;; prepare the buffer to be modified
+ (clear-visited-file-modtime)
+ (erase-buffer)
+
+ (let ((insert-okay-p nil)
+ (buffer (current-buffer))
+ (current-time (cmpl-hours-since-1900))
+ string num-uses entry last-use-time
+ cmpl-entry cmpl-last-use-time
+ (current-completion-source cmpl-source-init-file)
+ (start-num
+ (cmpl-statistics-block
+ (aref completion-add-count-vector cmpl-source-file-parsing)))
+ (total-in-file 0) (total-perm 0)
+ )
+ ;; insert the file into a buffer
+ (condition-case e
+ (progn (insert-file-contents filename t)
+ (setq insert-okay-p t))
+
+ (file-error
+ (message "File error trying to load completion file %s."
+ filename)))
+ ;; parse it
+ (when insert-okay-p
+ (goto-char (point-min))
+
+ (condition-case e
+ (while t
+ (setq entry (read buffer))
+ (setq total-in-file (1+ total-in-file))
+ (cond
+ ((and (consp entry)
+ (stringp (setq string (car entry)))
+ (cond
+ ((eq (setq last-use-time (cdr entry)) 'T)
+ ;; handle case sensitivity
+ (setq total-perm (1+ total-perm))
+ (setq last-use-time t))
+ ((eq last-use-time t)
+ (setq total-perm (1+ total-perm)))
+ ((integerp last-use-time))
+ ))
+ ;; Valid entry
+ ;; add it in
+ (setq cmpl-last-use-time
+ (completion-last-use-time
+ (setq cmpl-entry
+ (add-completion-to-tail-if-new string))
+ ))
+ (if (or (eq last-use-time t)
+ (and (> last-use-time 1000);;backcompatibility
+ (not (eq cmpl-last-use-time t))
+ (or (not cmpl-last-use-time)
+ ;; more recent
+ (> last-use-time cmpl-last-use-time))
+ ))
+ ;; update last-use-time
+ (set-completion-last-use-time cmpl-entry last-use-time)
+ ))
+ (t
+ ;; Bad format
+ (message "Error: invalid saved completion - %s"
+ (prin1-to-string entry))
+ ;; try to get back in sync
+ (search-forward "\n(")
+ )))
+ (search-failed
+ (message "End of file while reading completions.")
+ )
+ (end-of-file
+ (if (= (point) (point-max))
+ (if (not no-message-p)
+ (message "Loading completions from file %s . . . Done."
+ filename))
+ (message "End of file while reading completions.")
+ ))
+ ))
+
+ (cmpl-statistics-block
+ (record-load-completions
+ total-in-file total-perm
+ (- (aref completion-add-count-vector cmpl-source-init-file)
+ start-num)))
+
+ )))))
+
+(defun initialize-completions ()
+ "Loads the default completions file and sets up so that exiting emacs will
+automatically save the file."
+ (interactive)
+ (cond ((not cmpl-initialized-p)
+ (load-completions-from-file)
+ ))
+ (init-cmpl-emacs-idle-process)
+ (setq cmpl-initialized-p t)
+ )
+
+
+;;;-----------------------------------------------
+;;; Kill EMACS patch
+;;;-----------------------------------------------
+
+(completion-advise kill-emacs :before
+ ;; | All completion code should go in here
+ ;;\ /
+ (kill-emacs-save-completions)
+ ;;/ \
+ ;; | All completion code should go in here
+ (cmpl-statistics-block
+ (record-cmpl-kill-emacs))
+ )
+
+\f
+;;;-----------------------------------------------
+;;; Kill region patch
+;;;-----------------------------------------------
+
+;;; Patched to remove the most recent completion
+(defvar $$$cmpl-old-kill-region (symbol-function 'kill-region))
+
+(defun kill-region (&optional beg end)
+ "Kill between point and mark.
+The text is deleted but saved in the kill ring.
+The command \\[yank] can retrieve it from there.
+/(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
+
+This is the primitive for programs to kill text (as opposed to deleting it).
+Supply two arguments, character numbers indicating the stretch of text
+ to be killed.
+Any command that calls this function is a \"kill command\".
+If the previous command was also a kill command,
+the text killed this time appends to the text killed last time
+to make one entry in the kill ring.
+Patched to remove the most recent completion."
+ (interactive "*")
+ (cond ((and (eq last-command 'complete) (eq last-command-char ?\C-w))
+ (delete-region (point) cmpl-last-insert-location)
+ (insert cmpl-original-string)
+ (setq completion-to-accept nil)
+ (cmpl-statistics-block
+ (record-complete-failed))
+ )
+ (t
+ (if (not beg)
+ (setq beg (min (point) (mark))
+ end (max (point) (mark)))
+ )
+ (funcall $$$cmpl-old-kill-region beg end)
+ )))
+
+;;;-----------------------------------------------
+;;; Patches to self-insert-command.
+;;;-----------------------------------------------
+
+;;; Need 2 versions: generic seperator chars. and space (to get auto fill
+;;; to work)
+
+;;; All common separators (eg. space "(" ")" """) characters go through a
+;;; function to add new words to the list of words to complete from:
+;;; COMPLETION-SEPARATOR-SELF-INSERT-COMMAND (arg).
+;;; If the character before this was an alpha-numeric then this adds the
+;;; symbol befoe point to the completion list (using ADD-COMPLETION).
+
+(defun completion-separator-self-insert-command (arg)
+ (interactive "p")
+ (use-completion-before-separator)
+ (self-insert-command arg)
+ )
+
+(defun completion-separator-self-insert-autofilling (arg)
+ (interactive "p")
+ (use-completion-before-separator)
+ (self-insert-command arg)
+ (and (> (current-column) fill-column)
+ auto-fill-hook
+ (funcall auto-fill-hook))
+ )
+
+;;;-----------------------------------------------
+;;; Wrapping Macro
+;;;-----------------------------------------------
+
+;;; Note that because of the way byte compiling works, none of
+;;; the functions defined with this macro get byte compiled.
+
+(defmacro def-completion-wrapper (function-name type &optional new-name)
+ "Add a call to update the completion database before the function is
+executed. TYPE is the type of the wrapper to be added. Can be :before or
+:under."
+ (completion-advise-1
+ function-name ':before
+ (ecase type
+ (:before '((use-completion-before-point)))
+ (:separator '((use-completion-before-separator)))
+ (:under '((use-completion-under-point)))
+ (:under-or-before
+ '((use-completion-under-or-before-point)))
+ (:minibuffer-separator
+ '((let ((cmpl-syntax-table cmpl-standard-syntax-table))
+ (use-completion-before-separator))))
+ )
+ new-name
+ ))
+
+;;;(defun foo (x y z) (+ x y z))
+;;;foo
+;;;(macroexpand '(def-completion-wrapper foo :under))
+;;;(progn (defvar $$$cmpl-foo (symbol-function (quote foo))) (defun foo (&rest arglist) (progn (use-completion-under-point)) (cmpl-apply-as-top-level $$$cmpl-foo arglist)))
+;;;(defun bar (x y z) "Documentation" (+ x y z))
+;;;bar
+;;;(macroexpand '(def-completion-wrapper bar :under))
+;;;(progn (defvar $$$cmpl-bar (symbol-function (quote bar))) (defun bar (&rest arglist) "Documentation" (progn (use-completion-under-point)) (cmpl-apply-as-top-level $$$cmpl-bar arglist)))
+;;;(defun quuz (x &optional y z) "Documentation" (interactive "P") (+ x y z))
+;;;quuz
+;;;(macroexpand '(def-completion-wrapper quuz :before))
+;;;(progn (defvar $$$cmpl-quuz (symbol-function (quote quuz))) (defun quuz (&rest arglist) "Documentation" (interactive) (progn (use-completion-before-point)) (cmpl-apply-as-top-level $$$cmpl-quuz arglist)))
+
+
+;;;---------------------------------------------------------------------------
+;;; Patches to standard keymaps insert completions
+;;;---------------------------------------------------------------------------
+
+;;;-----------------------------------------------
+;;; Separators
+;;;-----------------------------------------------
+;;; We've used the completion syntax table given as a guide.
+;;;
+;;; Global separator chars.
+;;; We left out <tab> because there are too many special cases for it. Also,
+;;; in normal coding it's rarely typed after a word.
+(global-set-key " " 'completion-separator-self-insert-autofilling)
+(global-set-key "!" 'completion-separator-self-insert-command)
+(global-set-key "%" 'completion-separator-self-insert-command)
+(global-set-key "^" 'completion-separator-self-insert-command)
+(global-set-key "&" 'completion-separator-self-insert-command)
+(global-set-key "(" 'completion-separator-self-insert-command)
+(global-set-key ")" 'completion-separator-self-insert-command)
+(global-set-key "=" 'completion-separator-self-insert-command)
+(global-set-key "`" 'completion-separator-self-insert-command)
+(global-set-key "|" 'completion-separator-self-insert-command)
+(global-set-key "{" 'completion-separator-self-insert-command)
+(global-set-key "}" 'completion-separator-self-insert-command)
+(global-set-key "[" 'completion-separator-self-insert-command)
+(global-set-key "]" 'completion-separator-self-insert-command)
+(global-set-key ";" 'completion-separator-self-insert-command)
+(global-set-key "\"" 'completion-separator-self-insert-command)
+(global-set-key "'" 'completion-separator-self-insert-command)
+(global-set-key "#" 'completion-separator-self-insert-command)
+(global-set-key "," 'completion-separator-self-insert-command)
+(global-set-key "?" 'completion-separator-self-insert-command)
+
+;;; We include period and colon even though they are symbol chars because :
+;;; - in text we want to pick up the last word in a sentence.
+;;; - in C pointer refs. we want to pick up the first symbol
+;;; - it won't make a difference for lisp mode (package names are short)
+(global-set-key "." 'completion-separator-self-insert-command)
+(global-set-key ":" 'completion-separator-self-insert-command)
+
+;;; Lisp Mode diffs
+(define-key lisp-mode-map "!" 'self-insert-command)
+(define-key lisp-mode-map "&" 'self-insert-command)
+(define-key lisp-mode-map "%" 'self-insert-command)
+(define-key lisp-mode-map "?" 'self-insert-command)
+(define-key lisp-mode-map "=" 'self-insert-command)
+(define-key lisp-mode-map "^" 'self-insert-command)
+
+;;; C mode diffs.
+(def-completion-wrapper electric-c-semi :separator)
+(define-key c-mode-map "+" 'completion-separator-self-insert-command)
+(define-key c-mode-map "*" 'completion-separator-self-insert-command)
+(define-key c-mode-map "/" 'completion-separator-self-insert-command)
+
+;;; FORTRAN mode diffs. (these are defined when fortran is called)
+(defun completion-setup-fortran-mode ()
+ (define-key fortran-mode-map "+" 'completion-separator-self-insert-command)
+ (define-key fortran-mode-map "-" 'completion-separator-self-insert-command)
+ (define-key fortran-mode-map "*" 'completion-separator-self-insert-command)
+ (define-key fortran-mode-map "/" 'completion-separator-self-insert-command)
+ )
+
+;;;-----------------------------------------------
+;;; End of line chars.
+;;;-----------------------------------------------
+(def-completion-wrapper newline :separator)
+(def-completion-wrapper newline-and-indent :separator)
+(if (function-defined-and-loaded 'shell-send-input)
+ (def-completion-wrapper shell-send-input :separator))
+(def-completion-wrapper exit-minibuffer :minibuffer-separator)
+(def-completion-wrapper eval-print-last-sexp :separator)
+(def-completion-wrapper eval-last-sexp :separator)
+;;(def-completion-wrapper minibuffer-complete-and-exit :minibuffer)
+
+;;;-----------------------------------------------
+;;; Cursor movement
+;;;-----------------------------------------------
+
+(def-completion-wrapper next-line :under-or-before)
+(def-completion-wrapper previous-line :under-or-before)
+(def-completion-wrapper beginning-of-buffer :under-or-before)
+(def-completion-wrapper end-of-buffer :under-or-before)
+
+;; we patch these explicitly so they byte compile and so we don't have to
+;; patch the faster underlying function.
+
+(defun cmpl-beginning-of-line (&optional n)
+ "Move point to beginning of current line.\n\
+With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
+If scan reaches end of buffer, stop there without error."
+ (interactive "p")
+ (use-completion-under-or-before-point)
+ (beginning-of-line n)
+ )
+
+(defun cmpl-end-of-line (&optional n)
+ "Move point to end of current line.\n\
+With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
+If scan reaches end of buffer, stop there without error."
+ (interactive "p")
+ (use-completion-under-or-before-point)
+ (end-of-line n)
+ )
+
+(defun cmpl-forward-char (n)
+ "Move point right ARG characters (left if ARG negative).\n\
+On reaching end of buffer, stop and signal error."
+ (interactive "p")
+ (use-completion-under-or-before-point)
+ (forward-char n)
+ )
+(defun cmpl-backward-char (n)
+ "Move point left ARG characters (right if ARG negative).\n\
+On attempt to pass beginning or end of buffer, stop and signal error."
+ (interactive "p")
+ (use-completion-under-point)
+ (if (eq last-command 'complete)
+ ;; probably a failed completion if you have to back up
+ (cmpl-statistics-block (record-complete-failed)))
+ (backward-char n)
+ )
+
+(defun cmpl-forward-word (n)
+ "Move point forward ARG words (backward if ARG is negative).\n\
+Normally returns t.\n\
+If an edge of the buffer is reached, point is left there\n\
+and nil is returned."
+ (interactive "p")
+ (use-completion-under-or-before-point)
+ (forward-word n)
+ )
+(defun cmpl-backward-word (n)
+ "Move backward until encountering the end of a word.
+With argument, do this that many times.
+In programs, it is faster to call forward-word with negative arg."
+ (interactive "p")
+ (use-completion-under-point)
+ (if (eq last-command 'complete)
+ ;; probably a failed completion if you have to back up
+ (cmpl-statistics-block (record-complete-failed)))
+ (forward-word (- n))
+ )
+
+(defun cmpl-forward-sexp (n)
+ "Move forward across one balanced expression.
+With argument, do this that many times."
+ (interactive "p")
+ (use-completion-under-or-before-point)
+ (forward-sexp n)
+ )
+(defun cmpl-backward-sexp (n)
+ "Move backward across one balanced expression.
+With argument, do this that many times."
+ (interactive "p")
+ (use-completion-under-point)
+ (if (eq last-command 'complete)
+ ;; probably a failed completion if you have to back up
+ (cmpl-statistics-block (record-complete-failed)))
+ (backward-sexp n)
+ )
+
+(defun cmpl-delete-backward-char (n killflag)
+ "Delete the previous ARG characters (following, with negative ARG).\n\
+Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).\n\
+Interactively, ARG is the prefix arg, and KILLFLAG is set if\n\
+ARG was explicitly specified."
+ (interactive "p\nP")
+ (if (eq last-command 'complete)
+ ;; probably a failed completion if you have to back up
+ (cmpl-statistics-block (record-complete-failed)))
+ (delete-backward-char n killflag)
+ )
+
+(defvar $$$cmpl-old-backward-delete-char-untabify
+ (symbol-function 'backward-delete-char-untabify))
+
+(defun backward-delete-char-untabify (arg &optional killp)
+ "Delete characters backward, changing tabs into spaces.
+Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
+Interactively, ARG is the prefix arg (default 1)
+and KILLP is t if prefix arg is was specified."
+ (interactive "*p\nP")
+ (if (eq last-command 'complete)
+ ;; probably a failed completion if you have to back up
+ (cmpl-statistics-block (record-complete-failed)))
+ (funcall $$$cmpl-old-backward-delete-char-untabify arg killp)
+ )
+
+
+(global-set-key "\C-?" 'cmpl-delete-backward-char)
+(global-set-key "\M-\C-F" 'cmpl-forward-sexp)
+(global-set-key "\M-\C-B" 'cmpl-backward-sexp)
+(global-set-key "\M-F" 'cmpl-forward-word)
+(global-set-key "\M-B" 'cmpl-backward-word)
+(global-set-key "\C-F" 'cmpl-forward-char)
+(global-set-key "\C-B" 'cmpl-backward-char)
+(global-set-key "\C-A" 'cmpl-beginning-of-line)
+(global-set-key "\C-E" 'cmpl-end-of-line)
+
+;;;-----------------------------------------------
+;;; Misc.
+;;;-----------------------------------------------
+
+(def-completion-wrapper electric-buffer-list :under-or-before)
+(def-completion-wrapper list-buffers :under-or-before)
+(def-completion-wrapper scroll-up :under-or-before)
+(def-completion-wrapper scroll-down :under-or-before)
+(def-completion-wrapper execute-extended-command
+ :under-or-before)
+(def-completion-wrapper other-window :under-or-before)
+
+;;;-----------------------------------------------
+;;; Local Thinking Machines stuff
+;;;-----------------------------------------------
+
+(if (fboundp 'up-ten-lines)
+ (def-completion-wrapper up-ten-lines :under-or-before))
+(if (fboundp 'down-ten-lines)
+ (def-completion-wrapper down-ten-lines :under-or-before))
+(if (fboundp 'tmc-scroll-up)
+ (def-completion-wrapper tmc-scroll-up :under-or-before))
+(if (fboundp 'tmc-scroll-down)
+ (def-completion-wrapper tmc-scroll-down :under-or-before))
+(if (fboundp 'execute-extended-command-and-check-for-bindings)
+ (def-completion-wrapper execute-extended-command-and-check-for-bindings
+ :under-or-before))
+
+;;; Tests --
+;;; foobarbiz
+;;; foobar
+;;; fooquux
+;;; fooper
+
+(cmpl-statistics-block
+ (record-completion-file-loaded))
HCoop / bpt / emacs.git / commitdiff