(defgroup completion nil
"Dynamic word-completion code."
:group 'matching
:group 'convenience)
(defcustom enable-completion t
"Non-nil means enable recording and saving of completions.
If nil, no new words are added to the database or saved to the init file."
:type 'boolean
:group 'completion)
(defcustom save-completions-flag t
"Non-nil means save most-used completions when exiting Emacs.
See also `save-completions-retention-time'."
:type 'boolean
:group 'completion)
(defcustom save-completions-file-name
(let ((olddef (convert-standard-filename "~/.completions")))
(cond
((file-readable-p olddef) olddef)
((file-directory-p (convert-standard-filename "~/.emacs.d/"))
(convert-standard-filename
(expand-file-name "completions" "~/.emacs.d/")))
(t olddef)))
"The filename to save completions to."
:type 'file
:group 'completion)
(defcustom save-completions-retention-time 336
"Discard a completion if unused for this many 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."
:type 'integer
:group 'completion)
(defcustom completion-on-separator-character nil
"Non-nil means separator characters mark previous word as used.
This means the word will be saved as a completion."
:type 'boolean
:group 'completion)
(defcustom completions-file-versions-kept kept-new-versions
"Number of versions to keep for the saved completions file."
:type 'integer
:group 'completion)
(defcustom completion-prompt-speed-threshold 4800
"Minimum output speed at which to display next potential completion."
:type 'integer
:group 'completion)
(defcustom completion-cdabbrev-prompt-flag nil
"If non-nil, the next completion prompt does a cdabbrev search.
This can be time consuming."
:type 'boolean
:group 'completion)
(defcustom completion-search-distance 15000
"How far to search in the buffer when looking for completions.
In number of characters. If nil, search the whole buffer."
:type 'integer
:group 'completion)
(defcustom completions-merging-modes '(lisp c)
"List of modes {`c' or `lisp'} for automatic completions merging.
Definitions from visited files which have these modes
are automatically added to the completion database."
:type '(set (const lisp) (const c))
:group 'completion)
(defvar completion-min-length 6
"*The minimum length of a stored completion.
DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
(defvar completion-max-length 200
"*The maximum length of a stored completion.
DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
(defvar completion-prefix-min-length 3
"The minimum length of a completion search string.
DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
(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.")
(defvar cmpl-preceding-syntax)
(defvar completion-string)
(defun cmpl-string-case-type (string)
"Return :capitalized, :up, :down, :mixed, or :neither for case of STRING."
(let ((case-fold-search nil))
(cond ((string-match "[[:lower:]]" string)
(cond ((string-match "[[:upper:]]" string)
(cond ((and (> (length string) 1)
(null (string-match "[[:upper:]]" string 1)))
:capitalized)
(t
:mixed)))
(t :down)))
(t
(cond ((string-match "[[:upper:]]" string)
:up)
(t :neither))))))
(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))
(cmpl-coerce-string-case string-to-coerce
(cmpl-string-case-type given-string)))
(t
string-to-coerce))))
(defun cmpl-hours-since-origin ()
(let ((time (current-time)))
(floor (+ (* 65536.0 (nth 0 time)) (nth 1 time)) 3600)))
(defconst completion-standard-syntax-table
(let ((table (make-syntax-table))
i)
(setq i 0)
(while (< i 256)
(modify-syntax-entry i " " table)
(setq i (1+ i)))
(setq i 0)
(while (< i 26)
(modify-syntax-entry (+ ?a i) "_" table)
(modify-syntax-entry (+ ?A i) "_" table)
(setq i (1+ i)))
(setq i 0)
(while (< i 10)
(modify-syntax-entry (+ ?0 i) "_" table)
(setq i (1+ i)))
(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))
(defvar completion-syntax-table completion-standard-syntax-table
"This variable holds the current completion syntax table.")
(make-variable-buffer-local 'completion-syntax-table)
(defvar cmpl-symbol-start nil
"Holds first character of symbol, after any completion symbol function.")
(defvar cmpl-symbol-end nil
"Holds last character of symbol, after any completion symbol function.")
(defun symbol-under-point ()
"Return the symbol that the point is currently on.
But only if it is longer than `completion-min-length'."
(with-syntax-table completion-syntax-table
(when (memq (char-syntax (following-char)) '(?w ?_))
(let ((saved-point (point)))
(setq cmpl-symbol-start (scan-sexps (1+ saved-point) -1)
cmpl-symbol-end (scan-sexps saved-point 1))
(cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
(goto-char cmpl-symbol-start)
(forward-word 1)
(setq cmpl-symbol-start (point))
(goto-char saved-point)))
(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 saved-point)))
(if (and (<= completion-min-length
(- cmpl-symbol-end cmpl-symbol-start))
(<= (- cmpl-symbol-end cmpl-symbol-start)
completion-max-length))
(buffer-substring cmpl-symbol-start cmpl-symbol-end))))))
(defun symbol-before-point ()
"Return a string of the symbol immediately before point.
Returns nil if there isn't one longer than `completion-min-length'."
(with-syntax-table completion-syntax-table
(cond ((= (setq cmpl-preceding-syntax (char-syntax (preceding-char))) ?_)
(setq cmpl-symbol-end (point)
cmpl-symbol-start (scan-sexps cmpl-symbol-end -1))
(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)))
(if (>= cmpl-symbol-end
(+ cmpl-symbol-start completion-min-length))
(buffer-substring cmpl-symbol-start cmpl-symbol-end)))
((= cmpl-preceding-syntax ?w)
(let ((saved-point (point)))
(setq cmpl-symbol-start (scan-sexps saved-point -1))
(forward-word -1)
(setq cmpl-symbol-end (point))
(cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
(goto-char cmpl-symbol-start)
(forward-word 1)
(setq cmpl-symbol-start (point))))
(goto-char saved-point)
(if (and (<= completion-min-length
(- cmpl-symbol-end cmpl-symbol-start))
(<= (- cmpl-symbol-end cmpl-symbol-start)
completion-max-length))
(buffer-substring cmpl-symbol-start cmpl-symbol-end)))))))
(defun symbol-under-or-before-point ()
(if (memq (with-syntax-table completion-syntax-table
(char-syntax (following-char)))
'(?w ?_))
(symbol-under-point)
(symbol-before-point)))
(defun symbol-before-point-for-complete ()
(with-syntax-table completion-syntax-table
(cond ((memq (setq cmpl-preceding-syntax (char-syntax (preceding-char)))
'(?_ ?w))
(setq cmpl-symbol-end (point)
cmpl-symbol-start (scan-sexps cmpl-symbol-end -1))
(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)))
(if (and (<= completion-prefix-min-length
(- cmpl-symbol-end cmpl-symbol-start))
(<= (- cmpl-symbol-end cmpl-symbol-start)
completion-max-length))
(buffer-substring cmpl-symbol-start cmpl-symbol-end))))))
(defmacro cmpl-statistics-block (&rest body))
(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)
(defvar cdabbrev-completions-tried nil)
(defvar cdabbrev-current-point 0)
(defvar cdabbrev-current-window nil)
(defvar cdabbrev-wrapped-p nil)
(defvar cdabbrev-abbrev-string "")
(defvar cdabbrev-start-point 0)
(defvar cdabbrev-stop-point)
(defun reset-cdabbrev (abbrev-string &optional initial-completions-tried)
"Reset 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 ()
(set-buffer (if (eq cdabbrev-current-window t)
(other-buffer)
(window-buffer cdabbrev-current-window))))
(defun reset-cdabbrev-window (&optional initializep)
"Reset the cdabbrev search to search for abbrev-string."
(cond (initializep
(setq cdabbrev-current-window (selected-window)))
((eq cdabbrev-current-window t)
(setq cdabbrev-current-window nil))
(cdabbrev-current-window
(setq cdabbrev-current-window (next-window cdabbrev-current-window))
(if (eq cdabbrev-current-window (selected-window))
(setq cdabbrev-current-window t))))
(if cdabbrev-current-window
(save-excursion
(set-cdabbrev-buffer)
(setq cdabbrev-current-point (point)
cdabbrev-start-point cdabbrev-current-point
cdabbrev-stop-point
(if completion-search-distance
(max (point-min)
(- cdabbrev-start-point completion-search-distance))
(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 already.
This is sensitive to `case-fold-search'."
(if cdabbrev-current-window
(let (saved-point
saved-syntax
(expansion nil)
downcase-expansion tried-list syntax saved-point-2)
(save-excursion
(unwind-protect
(progn
(set-cdabbrev-buffer)
(setq saved-point (point)
saved-syntax (syntax-table))
(set-syntax-table completion-syntax-table)
(goto-char cdabbrev-current-point)
(while
(cond
( (search-backward cdabbrev-abbrev-string cdabbrev-stop-point t)
(not
(and
(or (= (setq syntax (char-syntax (preceding-char))) ? )
(and (= syntax ?w)
(progn
(setq saved-point-2 (point))
(forward-word -1)
(prog1
(= (char-syntax (preceding-char)) ? )
(goto-char saved-point-2)))))
(setq expansion (symbol-under-point))
(progn
(setq tried-list cdabbrev-completions-tried
downcase-expansion (downcase expansion))
(while (and tried-list
(not (string-equal downcase-expansion
(car tried-list))))
(setq tried-list (cdr tried-list)))
(if tried-list
(setq expansion nil)
t)))))
(cdabbrev-wrapped-p
nil)
(t
(goto-char (setq cdabbrev-current-point
(if completion-search-distance
(min (point-max) (+ cdabbrev-start-point completion-search-distance))
(point-max))))
(setq cdabbrev-wrapped-p t))))
(cond (expansion
(setq cdabbrev-completions-tried
(cons downcase-expansion cdabbrev-completions-tried)
cdabbrev-current-point (point)))))
(set-syntax-table saved-syntax)
(goto-char saved-point)))
(cond (expansion)
(t (reset-cdabbrev-window)
(next-cdabbrev))))))
(defconst cmpl-obarray-length 511)
(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)
"An obarray used to store the downcased completion prefixes.
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.")
(defmacro completion-string (completion-entry)
(list 'car completion-entry))
(defmacro completion-num-uses (completion-entry)
(list 'car (list 'cdr completion-entry)))
(defmacro completion-last-use-time (completion-entry)
(list 'nth 2 completion-entry))
(defmacro completion-source (completion-entry)
(list 'nth 3 completion-entry))
(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))
(defun make-completion (string)
"Return a completion entry."
(list string 0 nil current-completion-source))
(defalias 'cmpl-prefix-entry-head 'car)
(defalias 'cmpl-prefix-entry-tail 'cdr)
(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))
(defun make-cmpl-prefix-entry (completion-entry-list)
"Make a new prefix entry containing only completion-entry."
(cons completion-entry-list completion-entry-list))
(defun clear-all-completions ()
"Initialize 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)))
(defvar completions-list-return-value)
(defun list-all-completions ()
"Return a list of all the known completion entries."
(let ((completions-list-return-value nil))
(mapatoms 'list-all-completions-1 cmpl-prefix-obarray)
completions-list-return-value))
(defun list-all-completions-1 (prefix-symbol)
(if (boundp prefix-symbol)
(setq completions-list-return-value
(append (cmpl-prefix-entry-head (symbol-value prefix-symbol))
completions-list-return-value))))
(defun list-all-completions-by-hash-bucket ()
"Return list of lists of known completion entries, organized by hash bucket."
(let ((completions-list-return-value nil))
(mapatoms 'list-all-completions-by-hash-bucket-1 cmpl-prefix-obarray)
completions-list-return-value))
(defun list-all-completions-by-hash-bucket-1 (prefix-symbol)
(if (boundp prefix-symbol)
(setq completions-list-return-value
(cons (cmpl-prefix-entry-head (symbol-value prefix-symbol))
completions-list-return-value))))
(defvar completion-to-accept nil
"Set to a string that is pending its acceptance.")
(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.")
(defun find-exact-completion (string)
"Return 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)
"Return 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)
(defun locate-completion-entry (completion-entry prefix-entry)
"Locate 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))
(while (and prefix-list
(not (eq completion-entry
(car (setq next-prefix-list (cdr prefix-list))))))
(setq prefix-list next-prefix-list))
(cond ( prefix-list)
(cmpl-db-debug-p
(error "Completion entry exists but not on prefix list - %s"
completion-string))
(inside-locate-completion-entry
(locate-completion-db-error))
(t
(set cmpl-db-symbol nil)
(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)
(locate-completion-entry cmpl-entry pref-entry)
(locate-completion-db-error)))))
(defun locate-completion-db-error ()
(error "Completion database corrupted. Try M-x clear-all-completions. Send bug report"))
(defun add-completion-to-tail-if-new (string)
"If STRING is not in the database add it to appropriate prefix list.
STRING is added to the end of the appropriate 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)
(let ( (entry (list (make-completion string)))
(prefix-entry (find-cmpl-prefix-entry
(substring cmpl-db-downcase-string 0
completion-prefix-min-length))))
(cond (prefix-entry
(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))))
(cmpl-statistics-block
(note-added-completion))
(set cmpl-db-symbol (car entry)))))
(defun add-completion-to-head (completion-string)
"If COMPLETION-STRING is not in the database, add it to prefix list.
We add COMPLETION-STRING to the head of the appropriate prefix list,
or it to the head of the list.
COMPLETION-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."
(if completion-to-accept (accept-completion))
(if (setq cmpl-db-entry (find-exact-completion completion-string))
(let* ((prefix-entry (find-cmpl-prefix-entry
(substring cmpl-db-downcase-string 0
completion-prefix-min-length)))
(splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))
(cmpl-ptr (cdr splice-ptr)))
(set-completion-string cmpl-db-entry completion-string)
(cond (splice-ptr
(or (setcdr splice-ptr (cdr cmpl-ptr))
(set-cmpl-prefix-entry-tail prefix-entry splice-ptr))
(setcdr cmpl-ptr (cmpl-prefix-entry-head prefix-entry))
(set-cmpl-prefix-entry-head prefix-entry cmpl-ptr)))
cmpl-db-entry)
(let ( (entry (list (make-completion completion-string)))
(prefix-entry (find-cmpl-prefix-entry
(substring cmpl-db-downcase-string 0
completion-prefix-min-length))))
(cond (prefix-entry
(setcdr entry (cmpl-prefix-entry-head prefix-entry))
(set-cmpl-prefix-entry-head prefix-entry entry))
(t
(set cmpl-db-prefix-symbol (make-cmpl-prefix-entry entry))))
(cmpl-statistics-block
(note-added-completion))
(set cmpl-db-symbol (car entry)))))
(defun delete-completion (completion-string)
"Delete the completion from the database.
String must be longer than `completion-prefix-min-length'."
(if completion-to-accept (accept-completion))
(if (setq cmpl-db-entry (find-exact-completion completion-string))
(let* ((prefix-entry (find-cmpl-prefix-entry
(substring cmpl-db-downcase-string 0
completion-prefix-min-length)))
(splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry)))
(set cmpl-db-symbol nil)
(cond (splice-ptr
(or (setcdr splice-ptr (cdr (cdr splice-ptr)))
(set-cmpl-prefix-entry-tail prefix-entry splice-ptr)))
(t
(or (set-cmpl-prefix-entry-head
prefix-entry (cdr (cmpl-prefix-entry-head prefix-entry)))
(set cmpl-db-prefix-symbol nil))))
(cmpl-statistics-block
(note-completion-deleted)))
(error "Unknown completion `%s'" completion-string)))
(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)
"Add STRING to completion list, or move it to head of 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)
"Add STRING if it isn't already listed, and mark it permanent."
(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)
(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 ()
"Add the completion symbol underneath the point into the completion buffer."
(let ((string (and enable-completion (symbol-under-point)))
(current-completion-source cmpl-source-cursor-moves))
(if string (add-completion-to-head string))))
(defun use-completion-before-point ()
"Add the completion symbol before point into the completion buffer."
(let ((string (and enable-completion (symbol-before-point)))
(current-completion-source cmpl-source-cursor-moves))
(if string (add-completion-to-head string))))
(defun use-completion-under-or-before-point ()
"Add the completion symbol before point into the completion buffer."
(let ((string (and enable-completion (symbol-under-or-before-point)))
(current-completion-source cmpl-source-cursor-moves))
(if string (add-completion-to-head string))))
(defun use-completion-before-separator ()
"Add the completion symbol before point into the completion buffer.
Completions added this way will automatically be saved if
`completion-on-separator-character' is non-nil."
(let ((string (and enable-completion (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))
(if (and completion-on-separator-character
(zerop (completion-num-uses entry)))
(progn
(set-completion-num-uses entry 1)
(setq cmpl-completions-accepted-p t)))))))
(defvar cmpl-test-string "")
(defvar cmpl-test-regexp "")
(defvar cmpl-last-index 0)
(defvar cmpl-cdabbrev-reset-p nil)
(defvar cmpl-next-possibilities nil)
(defvar cmpl-starting-possibilities nil)
(defvar cmpl-next-possibility nil)
(defvar cmpl-tried-list nil)
(defun completion-search-reset (string)
"Set up the for completion searching for STRING.
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 completion-prefix-min-length))))
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)
"Return the next completion entry.
If INDEX is out of sequence, reset and start from the top.
If there are no more entries, try cdabbrev and returns only a string."
(cond
((= index (setq cmpl-last-index (1+ cmpl-last-index)))
(completion-search-peek t))
((< index 0)
(completion-search-reset-1)
(setq cmpl-last-index index)
(setq cmpl-next-possibilities (reverse cmpl-starting-possibilities))
(while (and (completion-search-peek nil)
(< (setq index (1+ index)) 0))
(setq cmpl-next-possibility nil))
(cond ((not cmpl-next-possibilities))
((= -1 cmpl-last-index)
(setq cmpl-next-possibilities cmpl-starting-possibilities))
(t
(setq cmpl-next-possibilities
(nthcdr (- (length cmpl-starting-possibilities)
(length cmpl-next-possibilities))
cmpl-starting-possibilities)))))
(t
(completion-search-reset-1)
(setq cmpl-last-index index)
(while (and (completion-search-peek t)
(not (< (setq index (1- index)) 0)))
(setq cmpl-next-possibility nil))))
(prog1
cmpl-next-possibility
(setq cmpl-next-possibility nil)))
(defun completion-search-peek (use-cdabbrev)
"Return the next completion entry without actually moving the pointers.
Calling this again or calling `completion-search-next' results in the same
string being returned. Depends on `case-fold-search'.
If there are no more entries, try cdabbrev and then return only a string."
(cond
(cmpl-next-possibility)
((and cmpl-next-possibilities
(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))
(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
(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)))
))
(defun completion-mode ()
"Toggle whether or not to add new words to the completion database."
(interactive)
(setq enable-completion (not enable-completion))
(message "Completion mode is now %s." (if enable-completion "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)
"Fill out a completion of the word before point.
Point is left at end. Consecutive 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")
(cond ((eq last-command this-command)
(delete-region cmpl-last-insert-location (point))
(setq cmpl-current-index (+ cmpl-current-index (or arg 1))))
(t
(if (not cmpl-initialized-p)
(completion-initialize)) (cond ((consp current-prefix-arg) (setq arg 0)
(setq cmpl-leave-point-at-start t))
(t
(setq cmpl-leave-point-at-start nil)))
(setq cmpl-original-string (symbol-before-point-for-complete))
(cond ((not cmpl-original-string)
(setq this-command 'failed-complete)
(error "To complete, point must be after a symbol at least %d character long"
completion-prefix-min-length)))
(setq cmpl-current-index (if current-prefix-arg arg 0))
(cmpl-statistics-block
(note-complete-entered-afresh cmpl-original-string))
(completion-search-reset cmpl-original-string)
(delete-region cmpl-symbol-start cmpl-symbol-end)))
(let* ((print-status-p
(and (>= baud-rate completion-prompt-speed-threshold)
(not (window-minibuffer-p (selected-window)))))
(insert-point (point))
(entry (completion-search-next cmpl-current-index))
string)
(cond (entry
(setq string (if (stringp entry)
entry (completion-string entry)))
(setq string (cmpl-merge-string-cases
string cmpl-original-string))
(insert string)
(setq completion-to-accept string)
(cond (cmpl-leave-point-at-start
(setq cmpl-last-insert-location (point))
(goto-char insert-point))
(t (setq cmpl-last-insert-location insert-point)))
(cmpl-statistics-block
(note-complete-inserted entry cmpl-current-index))
(cond
((and print-status-p
(sit-for 0)
(setq entry
(completion-search-peek
completion-cdabbrev-prompt-flag)))
(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 (insert cmpl-original-string)
(setq completion-to-accept nil)
(if (and print-status-p (sit-for 0))
(message "No %scompletions."
(if (eq this-command last-command) "more " "")))
(cmpl-statistics-block
(record-complete-failed cmpl-current-index))
(setq this-command 'failed-complete)))))
(defun add-completions-from-file (file)
"Parse possible completions from a FILE and add them to data base."
(interactive "fFile: ")
(setq file (expand-file-name file))
(let* ((buffer (get-file-buffer file))
(buffer-already-there-p buffer))
(if (not buffer-already-there-p)
(let ((completions-merging-modes nil))
(setq buffer (find-file-noselect file))))
(unwind-protect
(with-current-buffer buffer
(add-completions-from-buffer))
(if (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 "Cannot 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)))))
(defun completion-find-file-hook ()
(cond (enable-completion
(cond ((and (memq major-mode '(emacs-lisp-mode lisp-mode))
(memq 'lisp completions-merging-modes))
(add-completions-from-buffer))
((and (memq major-mode '(c-mode))
(memq 'c completions-merging-modes))
(add-completions-from-buffer))))))
(defun add-completions-from-tags-table ()
"Add completions from the current tags table."
(interactive)
(visit-tags-table-buffer) (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)))))
(defconst *lisp-def-regexp*
"\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
"A regexp that searches for Lisp definition form.")
(defun add-completions-from-lisp-buffer ()
(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)))))
(defconst completion-c-def-syntax-table
(let ((table (make-syntax-table))
(whitespace-chars '(? ?\n ?\t ?\f ?\v ?\r))
(separator-chars '(?, ?* ?= ?\( ?\ i)
(setq i 0)
(while (< i 256)
(modify-syntax-entry i "w" table)
(setq i (1+ i)))
(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 *c-def-regexp*
"\n[_a-zA-Z#]"
"A regexp that searches for a definition form.")
(defun add-completions-from-c-buffer ()
(let (string next-point char)
(save-excursion
(goto-char (point-min))
(catch 'finish-add-completions
(with-syntax-table completion-c-def-syntax-table
(while t
(condition-case e
(while t
(re-search-forward *c-def-regexp*)
(cond
((= (preceding-char) ?#)
(cond ((looking-at "\\(define\\|ifdef\\)\\>")
(and (forward-word 2)
(setq string (symbol-before-point))
(add-completion-to-tail-if-new string)))))
(t
(setq next-point (point))
(while (and
next-point
(setq next-point (scan-sexps next-point 1)))
(goto-char next-point)
(while (= (setq char (following-char)) ?*)
(goto-char
(setq next-point (scan-sexps (point) 1))))
(forward-word -1)
(if (setq string (symbol-under-point))
(add-completion-to-tail-if-new string)
(if (and (looking-at "_AP") (progn
(forward-word -1)
(setq string
(symbol-under-point))))
(add-completion-to-tail-if-new string)))
(goto-char next-point)
(if (= (char-syntax char) ?\()
(while (= (char-syntax char) ?\()
(setq next-point (scan-sexps next-point 1)
char (char-after next-point)))
(or (= char ?,)
(setq next-point nil)))))))
(search-failed (throw 'finish-add-completions t))
(error
(if (member (nth 1 e)
'("Containing expression ends prematurely"
"Unbalanced parentheses"))
(forward-line 1)
(message "Error parsing C buffer for completions--please send bug report")
(throw 'finish-add-completions t))))))))))
(defun kill-emacs-save-completions ()
(if (and save-completions-flag enable-completion cmpl-initialized-p)
(cond
((not cmpl-completions-accepted-p)
(message "Completions database has not changed - not writing."))
(t
(save-completions-to-file))))
(cmpl-statistics-block (record-cmpl-kill-emacs)))
(defconst completion-version "11")
(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 origin.
\n")
(defun completion-backup-filename (filename)
(concat filename ".BAK"))
(defun save-completions-to-file (&optional filename)
"Save completions in init file FILENAME.
If file name is not specified, use `save-completions-file-name'."
(interactive)
(setq filename (expand-file-name (or filename save-completions-file-name)))
(if (file-writable-p filename)
(progn
(if (not cmpl-initialized-p)
(completion-initialize)) (message "Saving completions to file %s" filename)
(let* ((delete-old-versions t)
(kept-old-versions 0)
(kept-new-versions completions-file-versions-kept)
last-use-time
(current-time (cmpl-hours-since-origin))
(total-in-db 0)
(total-perm 0)
(total-saved 0)
(backup-filename (completion-backup-filename filename)))
(with-current-buffer (get-buffer-create " *completion-save-buffer*")
(setq buffer-file-name filename)
(if (not (verify-visited-file-modtime (current-buffer)))
(progn
(message "Completion file has changed. Merging. . .")
(load-completions-from-file filename t)
(message "Merging finished. Saving completions to file %s" filename)))
(clear-visited-file-modtime)
(erase-buffer)
(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))
(cond ((or (and (eq last-use-time t)
(setq total-perm (1+ total-perm)))
(if (> (completion-num-uses completion) 0)
(setq last-use-time current-time)
(and last-use-time
(or (not save-completions-retention-time)
(< (- current-time last-use-time)
save-completions-retention-time)))))
(setq total-saved (1+ total-saved))
(insert (prin1-to-string (cons (completion-string completion)
last-use-time)) "\n"))))
(condition-case e
(let ((file-exists-p (file-exists-p filename)))
(if file-exists-p
(progn
(or (file-exists-p backup-filename)
(rename-file filename backup-filename))
(copy-file backup-filename filename t)))
(save-buffer)
(if file-exists-p
(delete-file backup-filename)))
(error
(set-buffer-modified-p nil)
(message "Couldn't save completion file `%s'" filename)))
(setq cmpl-completions-accepted-p nil) )
(cmpl-statistics-block
(record-save-completions total-in-db total-perm total-saved))))))
(defun load-completions-from-file (&optional filename no-message-p)
"Load a completion init file FILENAME.
If file is not specified, then use `save-completions-file-name'."
(interactive)
(setq filename (expand-file-name (or filename save-completions-file-name)))
(let* ((backup-filename (completion-backup-filename filename))
(backup-readable-p (file-readable-p backup-filename)))
(if backup-readable-p (setq filename backup-filename))
(if (file-readable-p filename)
(progn
(if (not no-message-p)
(message "Loading completions from %sfile %s . . ."
(if backup-readable-p "backup " "") filename))
(with-current-buffer (get-buffer-create " *completion-save-buffer*")
(setq buffer-file-name filename)
(clear-visited-file-modtime)
(erase-buffer)
(let ((insert-okay-p nil)
(buffer (current-buffer))
string 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))
(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)))
(if insert-okay-p
(progn
(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)
(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))))
(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) (not (eq cmpl-last-use-time t))
(or (not cmpl-last-use-time)
(> last-use-time cmpl-last-use-time))))
(set-completion-last-use-time cmpl-entry last-use-time)))
(t
(message "Error: invalid saved completion - %s"
(prin1-to-string entry))
(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 completion-initialize ()
"Load the default completions file.
Also sets up so that exiting Emacs will automatically save the file."
(interactive)
(unless cmpl-initialized-p
(load-completions-from-file)
(setq cmpl-initialized-p t)))
(defun completion-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 positions 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 "r")
(cond ((eq last-command 'complete)
(delete-region (point) cmpl-last-insert-location)
(insert cmpl-original-string)
(setq completion-to-accept nil)
(cmpl-statistics-block
(record-complete-failed)))
(t
(kill-region beg end))))
(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 auto-fill-function
(funcall auto-fill-function)))
(defun completion-def-wrapper (function-name type)
"Add a call to update the completion database before function execution.
TYPE is the type of the wrapper to be added. Can be :before or :under."
(put function-name 'completion-function
(cdr (assq type
'((:separator . use-completion-before-separator)
(:before . use-completion-before-point)
(:backward-under . use-completion-backward-under)
(:backward . use-completion-backward)
(:under . use-completion-under-point)
(:under-or-before . use-completion-under-or-before-point)
(:minibuffer-separator
. use-completion-minibuffer-separator))))))
(defun use-completion-minibuffer-separator ()
(let ((completion-syntax-table completion-standard-syntax-table))
(use-completion-before-separator)))
(defun use-completion-backward-under ()
(use-completion-under-point)
(if (eq last-command 'complete)
(cmpl-statistics-block (record-complete-failed))))
(defun use-completion-backward ()
(if (eq last-command 'complete)
(cmpl-statistics-block (record-complete-failed))))
(defun completion-before-command ()
(funcall (or (and (symbolp this-command)
(get this-command 'completion-function))
'use-completion-under-or-before-point)))
(defconst completion-lisp-syntax-table
(let ((table (copy-syntax-table completion-standard-syntax-table))
(symbol-chars '(?! ?& ?? ?= ?^)))
(dolist (char symbol-chars)
(modify-syntax-entry char "_" table))
table))
(defun completion-lisp-mode-hook ()
(setq completion-syntax-table completion-lisp-syntax-table)
(local-set-key "!" 'self-insert-command)
(local-set-key "&" 'self-insert-command)
(local-set-key "%" 'self-insert-command)
(local-set-key "?" 'self-insert-command)
(local-set-key "=" 'self-insert-command)
(local-set-key "^" 'self-insert-command))
(defconst completion-c-syntax-table
(let ((table (copy-syntax-table completion-standard-syntax-table))
(separator-chars '(?+ ?* ?/ ?: ?%)))
(dolist (char separator-chars)
(modify-syntax-entry char " " table))
table))
(completion-def-wrapper 'electric-c-semi :separator)
(defun completion-c-mode-hook ()
(setq completion-syntax-table completion-c-syntax-table)
(local-set-key "+" 'completion-separator-self-insert-command)
(local-set-key "*" 'completion-separator-self-insert-command)
(local-set-key "/" 'completion-separator-self-insert-command))
(defconst completion-fortran-syntax-table
(let ((table (copy-syntax-table completion-standard-syntax-table))
(separator-chars '(?+ ?- ?* ?/ ?:)))
(dolist (char separator-chars)
(modify-syntax-entry char " " table))
table))
(defun completion-setup-fortran-mode ()
(setq completion-syntax-table completion-fortran-syntax-table)
(local-set-key "+" 'completion-separator-self-insert-command)
(local-set-key "-" 'completion-separator-self-insert-command)
(local-set-key "*" 'completion-separator-self-insert-command)
(local-set-key "/" 'completion-separator-self-insert-command))
(defvar fortran-mode-hook)
(defvar completion-saved-bindings nil)
(define-minor-mode dynamic-completion-mode
"Enable dynamic word-completion."
:global t
(define-key function-key-map [C-return] [?\C-\r])
(dolist (x '((find-file-hook . completion-find-file-hook)
(pre-command-hook . completion-before-command)
(kill-emacs-hook . kill-emacs-save-completions)
(lisp-mode-hook . completion-lisp-mode-hook)
(c-mode-hook . completion-c-mode-hook)
(fortran-mode-hook . completion-setup-fortran-mode)))
(if dynamic-completion-mode
(add-hook (car x) (cdr x))
(remove-hook (car x) (cdr x))))
(while completion-saved-bindings
(let ((binding (pop completion-saved-bindings)))
(global-set-key (car binding) (cdr binding))))
(when dynamic-completion-mode
(dolist (binding
'(("\M-\r" . complete)
([?\C-\r] . complete)
([remap kill-region] . completion-kill-region)
(" " . completion-separator-self-insert-autofilling)
("!" . completion-separator-self-insert-command)
("%" . completion-separator-self-insert-command)
("^" . completion-separator-self-insert-command)
("&" . completion-separator-self-insert-command)
("(" . completion-separator-self-insert-command)
(")" . completion-separator-self-insert-command)
("=" . completion-separator-self-insert-command)
("`" . completion-separator-self-insert-command)
("|" . completion-separator-self-insert-command)
("{" . completion-separator-self-insert-command)
("}" . completion-separator-self-insert-command)
("[" . completion-separator-self-insert-command)
("]" . completion-separator-self-insert-command)
(";" . completion-separator-self-insert-command)
("\"". completion-separator-self-insert-command)
("'" . completion-separator-self-insert-command)
("#" . completion-separator-self-insert-command)
("," . completion-separator-self-insert-command)
("?" . completion-separator-self-insert-command)
("." . completion-separator-self-insert-command)
(":" . completion-separator-self-insert-command)))
(push (cons (car binding) (lookup-key global-map (car binding)))
completion-saved-bindings)
(global-set-key (car binding) (cdr binding)))
(cmpl-statistics-block
(record-completion-file-loaded))
(completion-initialize)))
(completion-def-wrapper 'newline :separator)
(completion-def-wrapper 'newline-and-indent :separator)
(completion-def-wrapper 'comint-send-input :separator)
(completion-def-wrapper 'exit-minibuffer :minibuffer-separator)
(completion-def-wrapper 'eval-print-last-sexp :separator)
(completion-def-wrapper 'eval-last-sexp :separator)
(completion-def-wrapper 'next-line :under-or-before)
(completion-def-wrapper 'previous-line :under-or-before)
(completion-def-wrapper 'beginning-of-buffer :under-or-before)
(completion-def-wrapper 'end-of-buffer :under-or-before)
(completion-def-wrapper 'beginning-of-line :under-or-before)
(completion-def-wrapper 'end-of-line :under-or-before)
(completion-def-wrapper 'forward-char :under-or-before)
(completion-def-wrapper 'forward-word :under-or-before)
(completion-def-wrapper 'forward-sexp :under-or-before)
(completion-def-wrapper 'backward-char :backward-under)
(completion-def-wrapper 'backward-word :backward-under)
(completion-def-wrapper 'backward-sexp :backward-under)
(completion-def-wrapper 'delete-backward-char :backward)
(completion-def-wrapper 'delete-backward-char-untabify :backward)
(defvaralias 'cmpl-syntax-table 'completion-syntax-table)
(defalias 'initialize-completions 'completion-initialize)
(dolist (x '("^To complete, the point must be after a symbol at least [0-9]* character long\\.$"
"^The string \".*\" is too short to be saved as a completion\\.$"))
(add-to-list 'debug-ignored-errors x))
(provide 'completion)