1 ;;; completion.el --- dynamic word-completion code
3 ;; Maintainer: bug-completion@think.com
8 ;;; This is a Completion system for GNU Emacs
11 ;;; Internet: completion@think.com, bug-completion@think.com
12 ;;; UUCP: {rutgers,harvard,mit-eddie}!think!completion
14 ;;; If you are a new user, we'd appreciate knowing your site name and
15 ;;; any comments you have.
20 ;;; This software is distributed free of charge and is in the public domain.
21 ;;; Anyone may use, duplicate or modify this program. Thinking Machines
22 ;;; Corporation does not restrict in any way the use of this software by
25 ;;; Thinking Machines Corporation provides absolutely no warranty of any kind.
26 ;;; The entire risk as to the quality and performance of this program is with
27 ;;; you. In no event will Thinking Machines Corporation be liable to you for
28 ;;; damages, including any lost profits, lost monies, or other special,
29 ;;; incidental or consequential damages arising out of the use of this program.
31 ;;; You must not restrict the distribution of this software.
33 ;;; Please keep this notice and author information in any copies you make.
40 ;;; Try using this. If you are like most you will be happy you did.
42 ;;; What to put in .emacs
43 ;;;-----------------------
44 ;;; (load "completion") ;; If it's not part of the standard band.
45 ;;; (initialize-completions)
47 ;;; For best results, be sure to byte-compile the file first.
52 ;;; Jim Salem {salem@think.com}
53 ;;; Brewster Kahle {brewster@think.com}
54 ;;; Thinking Machines Corporation
55 ;;; 245 First St., Cambridge MA 02142 (617) 876-1111
60 ;;; Bugs to bug-completion@think.com
61 ;;; Comments to completion@think.com
62 ;;; Requests to be added completion-request@think.com
66 ;;; Anonymous FTP from think.com
69 ;;;---------------------------------------------------------------------------
70 ;;; Documentation [Slightly out of date]
71 ;;;---------------------------------------------------------------------------
72 ;;; (also check the documentation string of the functions)
77 ;;; After you type a few characters, pressing the "complete" key inserts
78 ;;; the rest of the word you are likely to type.
80 ;;; This watches all the words that you type and remembers them. When
81 ;;; typing a new word, pressing "complete" (meta-return) "completes" the
82 ;;; word by inserting the most recently used word that begins with the
83 ;;; same characters. If you press meta-return repeatedly, it cycles
84 ;;; through all the words it knows about.
86 ;;; If you like the completion then just continue typing, it is as if you
87 ;;; entered the text by hand. If you want the inserted extra characters
88 ;;; to go away, type control-w or delete. More options are described below.
90 ;;; The guesses are made in the order of the most recently "used". Typing
91 ;;; in a word and then typing a separator character (such as a space) "uses"
92 ;;; the word. So does moving a cursor over the word. If no words are found,
93 ;;; it uses an extended version of the dabbrev style completion.
95 ;;; You automatically save the completions you use to a file between
98 ;;; Completion enables programmers to enter longer, more descriptive
99 ;;; variable names while typing fewer keystrokes than they normally would.
102 ;;; Full documentation
103 ;;;---------------------
105 ;;; A "word" is any string containing characters with either word or symbol
106 ;;; syntax. [E.G. Any alphanumeric string with hypens, underscores, etc.]
107 ;;; Unless you change the constants, you must type at least three characters
108 ;;; for the word to be recognized. Only words longer than 6 characters are
111 ;;; When you load this file, completion will be on. I suggest you use the
112 ;;; compiled version (because it is noticibly faster).
114 ;;; M-X completion-mode toggles whether or not new words are added to the
115 ;;; database by changing the value of *completep*.
117 ;;; SAVING/LOADING COMPLETIONS
118 ;;; Completions are automatically saved from one session to another
119 ;;; (unless *save-completions-p* or *completep* is nil).
120 ;;; Loading this file (or calling initialize-completions) causes EMACS
121 ;;; to load a completions database for a saved completions file
122 ;;; (default: ~/.completions). When you exit, EMACS saves a copy of the
123 ;;; completions that you
124 ;;; often use. When you next start, EMACS loads in the saved completion file.
126 ;;; The number of completions saved depends loosely on
127 ;;; *saved-completions-decay-factor*. Completions that have never been
128 ;;; inserted via "complete" are not saved. You are encouraged to experiment
129 ;;; with different functions (see compute-completion-min-num-uses).
131 ;;; Some completions are permanent and are always saved out. These
132 ;;; completions have their num-uses slot set to T. Use
133 ;;; add-permanent-completion to do this
135 ;;; Completions are saved only if *completep* is T. The number of old
136 ;;; versions kept of the saved completions file is controlled by
137 ;;; *completion-file-versions-kept*.
139 ;;; COMPLETE KEY OPTIONS
140 ;;; The complete function takes a numeric arguments.
141 ;;; control-u :: leave the point at the beginning of the completion rather
143 ;;; a number :: rotate through the possible completions by that amount
144 ;;; `-' :: same as -1 (insert previous completion)
146 ;;; HOW THE DATABASE IS MAINTAINED
149 ;;; UPDATING THE DATABASE MANUALLY
150 ;;; m-x kill-completion
151 ;;; kills the completion at point.
152 ;;; m-x add-completion
153 ;;; m-x add-permanent-completion
155 ;;; UPDATING THE DATABASE FROM A SOURCE CODE FILE
156 ;;; m-x add-completions-from-buffer
157 ;;; Parses all the definition names from a C or LISP mode buffer and
158 ;;; adds them to the completion database.
160 ;;; m-x add-completions-from-lisp-file
161 ;;; Parses all the definition names from a C or Lisp mode file and
162 ;;; adds them to the completion database.
164 ;;; UPDATING THE DATABASE FROM A TAGS TABLE
165 ;;; m-x add-completions-from-tags-table
166 ;;; Adds completions from the current tags-table-buffer.
168 ;;; HOW A COMPLETION IS FOUND
172 ;;; Completion is string case independent if case-fold-search has its
173 ;;; normal default of T. Also when the completion is inserted the case of the
174 ;;; entry is coerced appropriately.
175 ;;; [E.G. APP --> APPROPRIATELY app --> appropriately
176 ;;; App --> Appropriately]
179 ;;; The form `(initialize-completions)' initializes the completion system by
180 ;;; trying to load in the user's completions. After the first cal, further
181 ;;; calls have no effect so one should be careful not to put the form in a
182 ;;; site's standard site-init file.
184 ;;;---------------------------------------------------------------------------
188 ;;;-----------------------------------------------
190 ;;;-----------------------------------------------
192 ;;; Should run on 18.49, 18.52, and 19.0
193 ;;; Tested on vanilla version.
194 ;;; This requires the standard cl.el file. It could easily rewritten to not
195 ;;; require it. It defines remove which is not in cl.el.
198 ;;; The following functions are bashed but it is done carefully and should not
199 ;;; cause problems ::
200 ;;; kill-region, next-line, previous-line, newline, newline-and-indent,
204 ;;;---------------------------------------------------------------------------
205 ;;; Functions you might like to call
206 ;;;---------------------------------------------------------------------------
208 ;;; add-completion string &optional num-uses
209 ;;; Adds a new string to the database
211 ;;; add-permanent-completion string
212 ;;; Adds a new string to the database with num-uses = T
215 ;;; kill-completion string
216 ;;; Kills the completion from the database.
218 ;;; clear-all-completions
219 ;;; Clears the database
221 ;;; list-all-completions
222 ;;; Returns a list of all completions.
225 ;;; next-completion string &optional index
226 ;;; Returns a completion entry that starts with string.
228 ;;; find-exact-completion string
229 ;;; Returns a completion entry that exactly matches string.
232 ;;; Inserts a completion at point
234 ;;; initialize-completions
235 ;;; Loads the completions file and sets up so that exiting emacs will
238 ;;; save-completions-to-file &optional filename
239 ;;; load-completions-from-file &optional filename
241 ;;;-----------------------------------------------
243 ;;;-----------------------------------------------
245 ;;; get-completion-list string
247 ;;; These things are for manipulating the structure
248 ;;; make-completion string num-uses
249 ;;; completion-num-uses completion
250 ;;; completion-string completion
251 ;;; set-completion-num-uses completion num-uses
252 ;;; set-completion-string completion string
256 ;;;-----------------------------------------------
257 ;;; To Do :: (anybody ?)
258 ;;;-----------------------------------------------
260 ;;; Implement Lookup and keyboard interface in C
261 ;;; Add package prefix smarts (for Common Lisp)
262 ;;; Add autoprompting of possible completions after every keystroke (fast
263 ;;; terminals only !)
264 ;;; Add doc. to texinfo
267 ;;;-----------------------------------------------
269 ;;;-----------------------------------------------
270 ;;; Sometime in '84 Brewster implemented a somewhat buggy version for
271 ;;; Symbolics LISPMs.
272 ;;; Jan. '85 Jim became enamored of the idea and implemented a faster,
273 ;;; more robust version.
274 ;;; With input from many users at TMC, (rose, craig, and gls come to mind),
275 ;;; the current style of interface was developed.
276 ;;; 9/87, Jim and Brewster took terminals home. Yuck. After
277 ;;; complaining for a while Brewester implemented a subset of the current
278 ;;; LISPM version for GNU Emacs.
279 ;;; 8/88 After complaining for a while (and with sufficient
280 ;;; promised rewards), Jim reimplemented a version of GNU completion
281 ;;; superior to that of the LISPM version.
283 ;;;-----------------------------------------------
285 ;;;-----------------------------------------------
286 ;;; Cliff Lasser (cal@think.com), Kevin Herbert (kph@cisco.com),
287 ;;; eero@media-lab, kgk@cs.brown.edu, jla@ai.mit.edu,
289 ;;;-----------------------------------------------
291 ;;;-----------------------------------------------
292 ;;; From version 9 to 10
293 ;;; - Allowance for non-integral *completion-version* nos.
294 ;;; - Fix cmpl-apply-as-top-level for keyboard macros
295 ;;; - Fix broken completion merging (in save-completions-to-file)
296 ;;; - More misc. fixes for version 19.0 of emacs
298 ;;; From Version 8 to 9
299 ;;; - Ported to version 19.0 of emacs (backcompatible with version 18)
300 ;;; - Added add-completions-from-tags-table (with thanks to eero@media-lab)
302 ;;; From Version 7 to 8
303 ;;; - Misc. changes to comments
304 ;;; - new completion key bindings: c-x o, M->, M-<, c-a, c-e
305 ;;; - cdabbrev now checks all the visible window buffers and the "other buffer"
306 ;;; - `%' is now a symbol character rather than a separator (except in C mode)
308 ;;; From Version 6 to 7
309 ;;; - Fixed bug with saving out .completion file the first time
311 ;;; From Version 5 to 6
312 ;;; - removed statistics recording
313 ;;; - reworked advise to handle autoloads
314 ;;; - Fixed fortran mode support
315 ;;; - Added new cursor motion triggers
317 ;;; From Version 4 to 5
318 ;;; - doesn't bother saving if nothing has changed
319 ;;; - auto-save if haven't used for a 1/2 hour
320 ;;; - save period extended to two weeks
321 ;;; - minor fix to capitalization code
322 ;;; - added *completion-auto-save-period* to variables recorded.
323 ;;; - added reenter protection to cmpl-record-statistics-filter
324 ;;; - added backup protection to save-completions-to-file (prevents
325 ;;; problems with disk full errors)
329 ;;;-----------------------------------------------
332 ;;;-----------------------------------------------
334 ;;(require 'cl) ;; DOTIMES, etc. {actually done after variable defs.}
336 (defconst *completion-version
* 10
337 "Tested for EMACS versions 18.49, 18.52, 18.55 and beyond and 19.0.")
339 ;;;---------------------------------------------------------------------------
340 ;;; User changeable parameters
341 ;;;---------------------------------------------------------------------------
343 (defvar *completep
* t
344 "*Set to nil to turn off the completion hooks.
345 (No new words added to the database or saved to the init file).")
347 (defvar *save-completions-p
* t
348 "*If non-nil, the most useful completions are saved to disk when
349 exiting EMACS. See *saved-completions-decay-factor*.")
351 (defvar *saved-completions-filename
* "~/.completions"
352 "*The filename to save completions to.")
354 (defvar *saved-completion-retention-time
* 336
355 "*The maximum amount of time to save a completion for if it has not been used.
356 In hours. (1 day = 24, 1 week = 168). If this is 0, non-permanent completions
357 will not be saved unless these are used. Default is two weeks.")
359 (defvar *separator-character-uses-completion-p
* nil
360 "*If non-nil, typing a separator character after a completion symbol that
361 is not part of the database marks it as used (so it will be saved).")
363 (defvar *completion-file-versions-kept
* kept-new-versions
364 "*Set this to the number of versions you want save-completions-to-file
367 (defvar *print-next-completion-speed-threshold
* 4800
368 "*The baud rate at or above which to print the next potential completion
369 after inserting the current one."
372 (defvar *print-next-completion-does-cdabbrev-search-p
* nil
373 "*If non-nil, the next completion prompt will also do a cdabbrev search.
374 This can be time consuming.")
376 (defvar *cdabbrev-radius
* 15000
377 "*How far to search for cdabbrevs. In number of characters. If nil, the
378 whole buffer is searched.")
380 (defvar *modes-for-completion-find-file-hook
* '(lisp c
)
381 "*A list of modes {either C or Lisp}. Definitions from visited files
382 of those types are automatically added to the completion database.")
384 (defvar *record-cmpl-statistics-p
* nil
385 "*If non-nil, statistics are automatically recorded.")
387 (defvar *completion-auto-save-period
* 1800
388 "*The period in seconds to wait for emacs to be idle before autosaving
389 the completions. Default is a 1/2 hour.")
391 (defconst *completion-min-length
* nil
;; defined below in eval-when
392 "*The minimum length of a stored completion.
393 DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
395 (defconst *completion-max-length
* nil
;; defined below in eval-when
396 "*The maximum length of a stored completion.
397 DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
399 (defconst *completion-prefix-min-length
* nil
;; defined below in eval-when
400 "The minimum length of a completion search string.
401 DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
403 (defmacro eval-when-compile-load-eval
(&rest body
)
404 ;; eval everything before expanding
408 (defun completion-eval-when ()
409 (eval-when-compile-load-eval
410 ;; These vars. are defined at both compile and load time.
411 (setq *completion-min-length
* 6)
412 (setq *completion-max-length
* 200)
413 (setq *completion-prefix-min-length
* 3)
414 ;; Need this file around too
417 (completion-eval-when)
419 ;;;---------------------------------------------------------------------------
420 ;;; Internal Variables
421 ;;;---------------------------------------------------------------------------
423 (defvar cmpl-initialized-p nil
424 "Set to t when the completion system is initialized. Indicates that the
425 old completion file has been read in.")
427 (defvar cmpl-completions-accepted-p nil
428 "Set to T as soon as the first completion has been accepted. Used to
429 decide whether to save completions.")
432 ;;;---------------------------------------------------------------------------
434 ;;;---------------------------------------------------------------------------
436 ;;;-----------------------------------------------
438 ;;;-----------------------------------------------
440 (defun remove (item list
)
441 (setq list
(copy-sequence list
))
444 (defun minibuffer-window-selected-p ()
445 "True iff the current window is the minibuffer."
446 (eq (minibuffer-window) (selected-window)))
448 (eval-when-compile-load-eval
449 (defun function-needs-autoloading-p (symbol)
450 ;; True iff symbol is represents an autoloaded function and has not yet been
452 (and (listp (symbol-function symbol
))
453 (eq 'autoload
(car (symbol-function symbol
)))
456 (defun function-defined-and-loaded (symbol)
457 ;; True iff symbol is bound to a loaded function.
458 (and (fboundp symbol
) (not (function-needs-autoloading-p symbol
))))
460 (defmacro read-time-eval
(form)
461 ;; Like the #. reader macro
464 ;;;-----------------------------------------------
465 ;;; Emacs Version 19 compatibility
466 ;;;-----------------------------------------------
468 (defconst emacs-is-version-19
(string= (substring emacs-version
0 2) "19"))
470 (defun cmpl19-baud-rate ()
471 (if emacs-is-version-19
475 (defun cmpl19-sit-for (amount)
476 (if (and emacs-is-version-19
(= amount
0))
480 ;;;-----------------------------------------------
482 ;;;-----------------------------------------------
484 (defmacro completion-advise
(function-name where
&rest body
)
485 "Adds the body code before calling function. This advise is not compiled.
486 WHERE is either :BEFORE or :AFTER."
487 (completion-advise-1 function-name where body
)
490 (defmacro cmpl-apply-as-top-level
(function arglist
)
491 "Calls function-name interactively if inside a call-interactively."
492 (list 'cmpl-apply-as-top-level-1 function arglist
493 '(let ((executing-macro nil
)) (interactive-p)))
496 (defun cmpl-apply-as-top-level-1 (function arglist interactive-p
)
497 (if (and interactive-p
(commandp function
))
498 (call-interactively function
)
499 (apply function arglist
)
502 (eval-when-compile-load-eval
504 (defun cmpl-defun-preamble (function-name)
507 ;; This condition-case is here to stave
508 ;; off bizarre load time errors 18.52 gets
509 ;; on the function c-mode
510 (documentation function-name
)
512 (interactivep (commandp function-name
))
515 (if doc-string
(list doc-string
))
516 (if interactivep
'((interactive)))
519 (defun completion-advise-1 (function-name where body
&optional new-name
)
520 (unless new-name
(setq new-name function-name
))
521 (let ((quoted-name (list 'quote function-name
))
522 (quoted-new-name (list 'quote new-name
))
525 (cond ((function-needs-autoloading-p function-name
)
526 (list* 'defun
function-name '(&rest arglist
)
528 (cmpl-defun-preamble function-name
)
529 (list (list 'load
(second (symbol-function function-name
)))
531 (list 'completion-advise-1 quoted-name
532 (list 'quote where
) (list 'quote body
)
534 (list 'cmpl-apply-as-top-level quoted-new-name
'arglist
)
539 (intern (concat "$$$cmpl-" (symbol-name function-name
))))
543 (list 'defvar old-def-name
544 (list 'symbol-function quoted-name
))
545 (list* 'defun
new-name '(&rest arglist
)
547 (cmpl-defun-preamble function-name
)
550 (list (cons 'progn body
)
551 (list 'cmpl-apply-as-top-level
552 old-def-name
'arglist
)))
554 (list* (list 'cmpl-apply-as-top-level
555 old-def-name
'arglist
)
563 ;;;-----------------------------------------------
564 ;;; String case coercion
565 ;;;-----------------------------------------------
567 (defun cmpl-string-case-type (string)
568 "Returns :capitalized, :up, :down, :mixed, or :neither."
569 (let ((case-fold-search nil
))
570 (cond ((string-match "[a-z]" string
)
571 (cond ((string-match "[A-Z]" string
)
572 (cond ((and (> (length string
) 1)
573 (null (string-match "[A-Z]" string
1)))
579 (cond ((string-match "[A-Z]" string
)
585 ;;; (cmpl-string-case-type "123ABCDEF456") --> :up
586 ;;; (cmpl-string-case-type "123abcdef456") --> :down
587 ;;; (cmpl-string-case-type "123aBcDeF456") --> :mixed
588 ;;; (cmpl-string-case-type "123456") --> :neither
589 ;;; (cmpl-string-case-type "Abcde123") --> :capitalized
591 (defun cmpl-coerce-string-case (string case-type
)
592 (cond ((eq case-type
':down
) (downcase string
))
593 ((eq case-type
':up
) (upcase string
))
594 ((eq case-type
':capitalized
)
595 (setq string
(downcase string
))
596 (aset string
0 (logand ?
\337 (aref string
0)))
601 (defun cmpl-merge-string-cases (string-to-coerce given-string
)
602 (let ((string-case-type (cmpl-string-case-type string-to-coerce
))
604 (cond ((memq string-case-type
'(:down
:up
:capitalized
))
605 ;; Found string is in a standard case. Coerce to a type based on
607 (cmpl-coerce-string-case string-to-coerce
608 (cmpl-string-case-type given-string
))
611 ;; If the found string is in some unusual case, just insert it
617 ;;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456
618 ;;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456
619 ;;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456
620 ;;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456
623 ;;;-----------------------------------------------
624 ;;; Emacs Idle Time hooks
625 ;;;-----------------------------------------------
627 (defvar cmpl-emacs-idle-process nil
)
629 (defvar cmpl-emacs-idle-interval
150
630 "Seconds between running the Emacs idle process.")
632 (defun init-cmpl-emacs-idle-process ()
633 "Initialize the emacs idle process."
634 (let ((live (and cmpl-emacs-idle-process
635 (eq (process-status cmpl-emacs-idle-process
) 'run
)))
636 ;; do not allocate a pty
637 (process-connection-type nil
))
639 (kill-process cmpl-emacs-idle-process
))
640 (if cmpl-emacs-idle-process
641 (delete-process cmpl-emacs-idle-process
))
642 (setq cmpl-emacs-idle-process
643 (start-process "cmpl-emacs-idle" nil
645 "-n" (int-to-string cmpl-emacs-idle-interval
)))
646 (process-kill-without-query cmpl-emacs-idle-process
)
647 (set-process-filter cmpl-emacs-idle-process
'cmpl-emacs-idle-filter
)
650 (defvar cmpl-emacs-buffer nil
)
651 (defvar cmpl-emacs-point
0)
652 (defvar cmpl-emacs-last-command nil
)
653 (defvar cmpl-emacs-last-command-char nil
)
654 (defun cmpl-emacs-idle-p ()
655 ;; returns T if emacs has been idle
656 (if (and (eq cmpl-emacs-buffer
(current-buffer))
657 (= cmpl-emacs-point
(point))
658 (eq cmpl-emacs-last-command last-command
)
659 (eq last-command-char last-command-char
)
662 ;; otherwise, update count
663 (setq cmpl-emacs-buffer
(current-buffer))
664 (setq cmpl-emacs-point
(point))
665 (setq cmpl-emacs-last-command last-command
)
666 (setq last-command-char last-command-char
)
670 (defvar cmpl-emacs-idle-time
0
671 "The idle time of Emacs in seconds.")
673 (defvar inside-cmpl-emacs-idle-filter nil
)
674 (defvar cmpl-emacs-idle-time-hooks nil
)
676 (defun cmpl-emacs-idle-filter (proc string
)
677 ;; This gets called every cmpl-emacs-idle-interval seconds
678 ;; Update idle time clock
679 (if (cmpl-emacs-idle-p)
680 (incf cmpl-emacs-idle-time cmpl-emacs-idle-interval
)
681 (setq cmpl-emacs-idle-time
0))
683 (unless inside-cmpl-emacs-idle-filter
684 ;; Don't reenter if we are hung
686 (setq inside-cmpl-emacs-idle-filter t
)
688 (dolist (function cmpl-emacs-idle-time-hooks
)
693 (setq inside-cmpl-emacs-idle-filter nil
)
697 ;;;-----------------------------------------------
699 ;;;-----------------------------------------------
700 ;;; What a backwards way to get the time! Unfortunately, GNU Emacs
701 ;;; doesn't have an accessible time function.
703 (defconst cmpl-hours-per-day
24)
704 (defconst cmpl-hours-per-year
(* 365 cmpl-hours-per-day
))
705 (defconst cmpl-hours-per-4-years
(+ (* 4 cmpl-hours-per-year
)
707 (defconst cmpl-days-since-start-of-year
708 '(0 31 59 90 120 151 181 212 243 273 304 334))
709 (defconst cmpl-days-since-start-of-leap-year
710 '(0 31 60 91 121 152 182 213 244 274 305 335))
711 (defconst cmpl-months
712 '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
714 (defun cmpl-hours-since-1900-internal (month day year hours
)
715 "Month is an integer from 1 to 12. Year is a two digit integer (19XX)"
717 (* (/ (1- year
) 4) cmpl-hours-per-4-years
)
718 (* (1+ (mod (1- year
) 4)) cmpl-hours-per-year
)
719 ;; minus two to account for 1968 rather than 1900
721 (* cmpl-hours-per-day
722 (nth (1- month
) (if (zerop (mod year
4))
723 cmpl-days-since-start-of-leap-year
724 cmpl-days-since-start-of-year
)))
725 (* (1- day
) cmpl-hours-per-day
)
728 (defun cmpl-month-from-string (month-string)
729 "Month string is a three char. month string"
731 (do ((list cmpl-months
(cdr list
))
733 ((or (null list
) (string-equal month-string
(car list
))))
734 (setq count
(1+ count
)))
736 (error "Unknown month - %s" month-string
))
739 (defun cmpl-hours-since-1900 (&optional time-string
)
740 "String is a string in the format of current-time-string (the default)."
741 (let* ((string (or time-string
(current-time-string)))
742 (month (cmpl-month-from-string (substring string
4 7)))
743 (day (string-to-int (substring string
8 10)))
744 (year (string-to-int (substring string
22 24)))
745 (hour (string-to-int (substring string
11 13)))
747 (cmpl-hours-since-1900-internal month day year hour
)))
750 ;;;(cmpl-hours-since-1900 "Wed Jan 1 00:00:28 1900") --> 35040
751 ;;;(cmpl-hours-since-1900 "Wed Nov 2 23:00:28 1988") --> 778751
752 ;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1988") --> 771926
753 ;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1988") --> 772670
754 ;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1988") --> 773366
755 ;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1988") --> 774110
756 ;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1988") --> 774830
757 ;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1988") --> 775574
758 ;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1988") --> 776294
759 ;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1988") --> 777038
760 ;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1988") --> 777782
761 ;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1988") --> 778502
762 ;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1988") --> 779246
763 ;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1988") --> 779966
764 ;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1957") --> 500198
765 ;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1957") --> 500942
766 ;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1957") --> 501614
767 ;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1957") --> 502358
768 ;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1957") --> 503078
769 ;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1957") --> 503822
770 ;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1957") --> 504542
771 ;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1957") --> 505286
772 ;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1957") --> 506030
773 ;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1957") --> 506750
774 ;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1957") --> 507494
775 ;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1957") --> 508214
778 ;;;---------------------------------------------------------------------------
779 ;;; "Symbol" parsing functions
780 ;;;---------------------------------------------------------------------------
781 ;;; The functions symbol-before-point, symbol-under-point, etc. quickly return
782 ;;; an appropriate symbol string. The strategy is to temporarily change
783 ;;; the syntax table to enable fast symbol searching. There are three classes
784 ;;; of syntax in these "symbol" syntax tables ::
786 ;;; syntax (?_) - "symbol" chars (e.g. alphanumerics)
787 ;;; syntax (?w) - symbol chars to ignore at end of words (e.g. period).
788 ;;; syntax (? ) - everything else
790 ;;; Thus by judicious use of scan-sexps and forward-word, we can get
791 ;;; the word we want relatively fast and without consing.
793 ;;; Why do we need a separate category for "symbol chars to ignore at ends" ?
794 ;;; For example, in LISP we want starting :'s trimmed
795 ;;; so keyword argument specifiers also define the keyword completion. And,
796 ;;; for example, in C we want `.' appearing in a structure ref. to
797 ;;; be kept intact in order to store the whole structure ref.; however, if
798 ;;; it appears at the end of a symbol it should be discarded because it is
799 ;;; probably used as a period.
801 ;;; Here is the default completion syntax ::
802 ;;; Symbol chars :: A-Z a-z 0-9 @ / \ * + ~ $ < > %
803 ;;; Symbol chars to ignore at ends :: _ : . -
804 ;;; Separator chars. :: <tab> <space> ! ^ & ( ) = ` | { } [ ] ; " ' #
805 ;;; , ? <Everything else>
807 ;;; Mode specific differences and notes ::
809 ;;; Symbol chars :: ! & ? = ^
812 ;;; Separator chars :: + * / : %
813 ;;; A note on the hypen (`-'). Perhaps, the hypen should also be a separator
814 ;;; char., however, we wanted to have completion symbols include pointer
815 ;;; references. For example, "foo->bar" is a symbol as far as completion is
819 ;;; Separator chars :: + - * / :
821 ;;; Pathname diffs ->
822 ;;; Symbol chars :: .
823 ;;; Of course there is no pathname "mode" and in fact we have not implemented
824 ;;; this table. However, if there was such a mode, this is what it would look
827 ;;;-----------------------------------------------
828 ;;; Table definitions
829 ;;;-----------------------------------------------
831 (defun make-standard-completion-syntax-table ()
832 (let ((table (make-vector 256 0)) ;; default syntax is whitespace
836 (modify-syntax-entry (+ ?a i
) "_" table
)
837 (modify-syntax-entry (+ ?A i
) "_" table
))
840 (modify-syntax-entry (+ ?
0 i
) "_" table
))
842 (let ((symbol-chars '(?
@ ?
/ ?
\\ ?
* ?
+ ?~ ?$ ?
< ?
> ?%
))
843 (symbol-chars-ignore '(?_ ?- ?
: ?.
))
845 (dolist (char symbol-chars
)
846 (modify-syntax-entry char
"_" table
))
847 (dolist (char symbol-chars-ignore
)
848 (modify-syntax-entry char
"w" table
)
853 (defconst cmpl-standard-syntax-table
(make-standard-completion-syntax-table))
855 (defun make-lisp-completion-syntax-table ()
856 (let ((table (copy-syntax-table cmpl-standard-syntax-table
))
857 (symbol-chars '(?
! ?
& ?? ?
= ?^
))
859 (dolist (char symbol-chars
)
860 (modify-syntax-entry char
"_" table
))
863 (defun make-c-completion-syntax-table ()
864 (let ((table (copy-syntax-table cmpl-standard-syntax-table
))
865 (separator-chars '(?
+ ?
* ?
/ ?
: ?%
))
867 (dolist (char separator-chars
)
868 (modify-syntax-entry char
" " table
))
871 (defun make-fortran-completion-syntax-table ()
872 (let ((table (copy-syntax-table cmpl-standard-syntax-table
))
873 (separator-chars '(?
+ ?- ?
* ?
/ ?
:))
875 (dolist (char separator-chars
)
876 (modify-syntax-entry char
" " table
))
879 (defconst cmpl-lisp-syntax-table
(make-lisp-completion-syntax-table))
880 (defconst cmpl-c-syntax-table
(make-c-completion-syntax-table))
881 (defconst cmpl-fortran-syntax-table
(make-fortran-completion-syntax-table))
883 (defvar cmpl-syntax-table cmpl-standard-syntax-table
884 "This variable holds the current completion syntax table.")
885 (make-variable-buffer-local 'cmpl-syntax-table
)
887 ;;;-----------------------------------------------
888 ;;; Installing the appropriate mode tables
889 ;;;-----------------------------------------------
891 (completion-advise lisp-mode-variables
:after
892 (setq cmpl-syntax-table cmpl-lisp-syntax-table
)
895 (completion-advise c-mode
:after
896 (setq cmpl-syntax-table cmpl-c-syntax-table
)
899 (completion-advise fortran-mode
:after
900 (setq cmpl-syntax-table cmpl-fortran-syntax-table
)
901 (completion-setup-fortran-mode)
904 ;;;-----------------------------------------------
906 ;;;-----------------------------------------------
907 (defvar cmpl-symbol-start nil
908 "Set to the first character of the symbol after one of the completion
909 symbol functions is called.")
910 (defvar cmpl-symbol-end nil
911 "Set to the last character of the symbol after one of the completion
912 symbol functions is called.")
913 ;;; These are temp. vars. we use to avoid using let.
914 ;;; Why ? Small speed improvement.
915 (defvar cmpl-saved-syntax nil
)
916 (defvar cmpl-saved-point nil
)
918 (defun symbol-under-point ()
919 "Returns the symbol that the point is currently on if it is longer
920 than *completion-min-length*."
921 (setq cmpl-saved-syntax
(syntax-table))
922 (set-syntax-table cmpl-syntax-table
)
924 ;; Cursor is on following-char and after preceding-char
925 ((memq (char-syntax (following-char)) '(?w ?_
))
926 (setq cmpl-saved-point
(point)
927 cmpl-symbol-start
(scan-sexps (1+ cmpl-saved-point
) -
1)
928 cmpl-symbol-end
(scan-sexps cmpl-saved-point
1))
929 ;; remove chars to ignore at the start
930 (cond ((= (char-syntax (char-after cmpl-symbol-start
)) ?w
)
931 (goto-char cmpl-symbol-start
)
933 (setq cmpl-symbol-start
(point))
934 (goto-char cmpl-saved-point
)
936 ;; remove chars to ignore at the end
937 (cond ((= (char-syntax (char-after (1- cmpl-symbol-end
))) ?w
)
938 (goto-char cmpl-symbol-end
)
940 (setq cmpl-symbol-end
(point))
941 (goto-char cmpl-saved-point
)
944 (set-syntax-table cmpl-saved-syntax
)
945 ;; Return completion if the length is reasonable
946 (if (and (<= (read-time-eval *completion-min-length
*)
947 (- cmpl-symbol-end cmpl-symbol-start
))
948 (<= (- cmpl-symbol-end cmpl-symbol-start
)
949 (read-time-eval *completion-max-length
*)))
950 (buffer-substring cmpl-symbol-start cmpl-symbol-end
))
953 ;; restore table if no symbol
954 (set-syntax-table cmpl-saved-syntax
)
958 ;;; tests for symbol-under-point
959 ;;; `^' indicates cursor pos. where value is returned
961 ;;; ^^^^^^^^^^^^^^^^ --> simple-word-test
962 ;;; _harder_word_test_
963 ;;; ^^^^^^^^^^^^^^^^^^ --> harder_word_test
966 ;;; /foo/bar/quux.hello
967 ;;; ^^^^^^^^^^^^^^^^^^^ --> /foo/bar/quux.hello
970 (defun symbol-before-point ()
971 "Returns a string of the symbol immediately before point
972 or nil if there isn't one longer than *completion-min-length*."
973 ;; This is called when a word separator is typed so it must be FAST !
974 (setq cmpl-saved-syntax
(syntax-table))
975 (set-syntax-table cmpl-syntax-table
)
976 ;; Cursor is on following-char and after preceding-char
977 (cond ((= (setq cmpl-preceding-syntax
(char-syntax (preceding-char))) ?_
)
978 ;; No chars. to ignore at end
979 (setq cmpl-symbol-end
(point)
980 cmpl-symbol-start
(scan-sexps (1+ cmpl-symbol-end
) -
1)
982 ;; remove chars to ignore at the start
983 (cond ((= (char-syntax (char-after cmpl-symbol-start
)) ?w
)
984 (goto-char cmpl-symbol-start
)
986 (setq cmpl-symbol-start
(point))
987 (goto-char cmpl-symbol-end
)
990 (set-syntax-table cmpl-saved-syntax
)
991 ;; return value if long enough
992 (if (>= cmpl-symbol-end
994 (read-time-eval *completion-min-length
*)))
995 (buffer-substring cmpl-symbol-start cmpl-symbol-end
))
997 ((= cmpl-preceding-syntax ?w
)
998 ;; chars to ignore at end
999 (setq cmpl-saved-point
(point)
1000 cmpl-symbol-start
(scan-sexps (1+ cmpl-saved-point
) -
1))
1001 ;; take off chars. from end
1003 (setq cmpl-symbol-end
(point))
1004 ;; remove chars to ignore at the start
1005 (cond ((= (char-syntax (char-after cmpl-symbol-start
)) ?w
)
1006 (goto-char cmpl-symbol-start
)
1008 (setq cmpl-symbol-start
(point))
1011 (goto-char cmpl-saved-point
)
1012 (set-syntax-table cmpl-saved-syntax
)
1013 ;; Return completion if the length is reasonable
1014 (if (and (<= (read-time-eval *completion-min-length
*)
1015 (- cmpl-symbol-end cmpl-symbol-start
))
1016 (<= (- cmpl-symbol-end cmpl-symbol-start
)
1017 (read-time-eval *completion-max-length
*)))
1018 (buffer-substring cmpl-symbol-start cmpl-symbol-end
))
1021 ;; restore table if no symbol
1022 (set-syntax-table cmpl-saved-syntax
)
1026 ;;; tests for symbol-before-point
1027 ;;; `^' indicates cursor pos. where value is returned
1028 ;;; simple-word-test
1032 ;;; ^ --> simple-word-test
1033 ;;; _harder_word_test_
1034 ;;; ^ --> harder_word_test
1035 ;;; ^ --> harder_word_test
1040 (defun symbol-under-or-before-point ()
1041 ;;; This could be made slightly faster but it is better to avoid
1042 ;;; copying all the code.
1043 ;;; However, it is only used by the completion string prompter.
1044 ;;; If it comes into common use, it could be rewritten.
1045 (setq cmpl-saved-syntax
(syntax-table))
1046 (set-syntax-table cmpl-syntax-table
)
1047 (cond ((memq (char-syntax (following-char)) '(?w ?_
))
1048 (set-syntax-table cmpl-saved-syntax
)
1049 (symbol-under-point))
1051 (set-syntax-table cmpl-saved-syntax
)
1052 (symbol-before-point))
1056 (defun symbol-before-point-for-complete ()
1057 ;; "Returns a string of the symbol immediately before point
1058 ;; or nil if there isn't one. Like symbol-before-point but doesn't trim the
1060 ;; Cursor is on following-char and after preceding-char
1061 (setq cmpl-saved-syntax
(syntax-table))
1062 (set-syntax-table cmpl-syntax-table
)
1063 (cond ((memq (setq cmpl-preceding-syntax
(char-syntax (preceding-char)))
1065 (setq cmpl-symbol-end
(point)
1066 cmpl-symbol-start
(scan-sexps (1+ cmpl-symbol-end
) -
1)
1068 ;; remove chars to ignore at the start
1069 (cond ((= (char-syntax (char-after cmpl-symbol-start
)) ?w
)
1070 (goto-char cmpl-symbol-start
)
1072 (setq cmpl-symbol-start
(point))
1073 (goto-char cmpl-symbol-end
)
1076 (set-syntax-table cmpl-saved-syntax
)
1077 ;; Return completion if the length is reasonable
1078 (if (and (<= (read-time-eval
1079 *completion-prefix-min-length
*)
1080 (- cmpl-symbol-end cmpl-symbol-start
))
1081 (<= (- cmpl-symbol-end cmpl-symbol-start
)
1082 (read-time-eval *completion-max-length
*)))
1083 (buffer-substring cmpl-symbol-start cmpl-symbol-end
))
1086 ;; restore table if no symbol
1087 (set-syntax-table cmpl-saved-syntax
)
1091 ;;; tests for symbol-before-point-for-complete
1092 ;;; `^' indicates cursor pos. where value is returned
1093 ;;; simple-word-test
1097 ;;; ^ --> simple-word-test
1098 ;;; _harder_word_test_
1099 ;;; ^ --> harder_word_test
1100 ;;; ^ --> harder_word_test_
1107 ;;;---------------------------------------------------------------------------
1108 ;;; Statistics Recording
1109 ;;;---------------------------------------------------------------------------
1111 ;;; Note that the guts of this has been turned off. The guts
1112 ;;; are in completion-stats.el.
1114 ;;;-----------------------------------------------
1115 ;;; Conditionalizing code on *record-cmpl-statistics-p*
1116 ;;;-----------------------------------------------
1117 ;;; All statistics code outside this block should use this
1118 (defmacro cmpl-statistics-block
(&rest body
)
1119 "Only executes body if we are recording statistics."
1121 (list* '*record-cmpl-statistics-p
* body
)
1124 ;;;-----------------------------------------------
1125 ;;; Completion Sources
1126 ;;;-----------------------------------------------
1129 (defconst cmpl-source-unknown
0)
1130 (defconst cmpl-source-init-file
1)
1131 (defconst cmpl-source-file-parsing
2)
1132 (defconst cmpl-source-separator
3)
1133 (defconst cmpl-source-cursor-moves
4)
1134 (defconst cmpl-source-interactive
5)
1135 (defconst cmpl-source-cdabbrev
6)
1136 (defconst num-cmpl-sources
7)
1137 (defvar current-completion-source cmpl-source-unknown
)
1141 ;;;---------------------------------------------------------------------------
1142 ;;; Completion Method #2: dabbrev-expand style
1143 ;;;---------------------------------------------------------------------------
1145 ;;; This method is used if there are no useful stored completions. It is
1146 ;;; based on dabbrev-expand with these differences :
1147 ;;; 1) Faster (we don't use regexps)
1148 ;;; 2) case coercion handled correctly
1149 ;;; This is called cdabbrev to differentiate it.
1150 ;;; We simply search backwards through the file looking for words which
1151 ;;; start with the same letters we are trying to complete.
1154 (defvar cdabbrev-completions-tried nil
)
1155 ;;; "A list of all the cdabbrev completions since the last reset.")
1157 (defvar cdabbrev-current-point
0)
1158 ;;; "The current point position the cdabbrev search is at.")
1160 (defvar cdabbrev-current-window nil
)
1161 ;;; "The current window we are looking for cdabbrevs in. T if looking in
1162 ;;; (other-buffer), NIL if no more cdabbrevs.")
1164 (defvar cdabbrev-wrapped-p nil
)
1165 ;;; "T if the cdabbrev search has wrapped around the file.")
1167 (defvar cdabbrev-abbrev-string
"")
1168 (defvar cdabbrev-start-point
0)
1170 ;;; Test strings for cdabbrev
1171 ;;; cdat-upcase ;;same namestring
1172 ;;; CDAT-UPCASE ;;ok
1173 ;;; cdat2 ;;too short
1174 ;;; cdat-1-2-3-4 ;;ok
1175 ;;; a-cdat-1 ;;doesn't start correctly
1176 ;;; cdat-simple ;;ok
1179 (defun reset-cdabbrev (abbrev-string &optional initial-completions-tried
)
1180 "Resets the cdabbrev search to search for abbrev-string.
1181 initial-completions-tried is a list of downcased strings to ignore
1183 (setq cdabbrev-abbrev-string abbrev-string
1184 cdabbrev-completions-tried
1185 (cons (downcase abbrev-string
) initial-completions-tried
)
1187 (reset-cdabbrev-window t
)
1190 (defun set-cdabbrev-buffer ()
1191 ;; cdabbrev-current-window must not be NIL
1192 (set-buffer (if (eq cdabbrev-current-window t
)
1194 (window-buffer cdabbrev-current-window
)))
1198 (defun reset-cdabbrev-window (&optional initializep
)
1199 "Resets the cdabbrev search to search for abbrev-string.
1200 initial-completions-tried is a list of downcased strings to ignore
1204 (setq cdabbrev-current-window
(selected-window))
1206 ((eq cdabbrev-current-window t
)
1207 ;; Everything has failed
1208 (setq cdabbrev-current-window nil
))
1209 (cdabbrev-current-window
1210 (setq cdabbrev-current-window
(next-window cdabbrev-current-window
))
1211 (if (eq cdabbrev-current-window
(selected-window))
1212 ;; No more windows, try other buffer.
1213 (setq cdabbrev-current-window t
)))
1215 (when cdabbrev-current-window
1217 (set-cdabbrev-buffer)
1218 (setq cdabbrev-current-point
(point)
1219 cdabbrev-start-point cdabbrev-current-point
1221 (if *cdabbrev-radius
*
1223 (- cdabbrev-start-point
*cdabbrev-radius
*))
1225 cdabbrev-wrapped-p nil
)
1228 (defun next-cdabbrev ()
1229 "Return the next possible cdabbrev expansion or nil if there isn't one.
1230 reset-cdabbrev must've been called. This is sensitive to case-fold-search."
1231 ;; note that case-fold-search affects the behavior of this function
1232 ;; Bug: won't pick up an expansion that starts at the top of buffer
1233 (when cdabbrev-current-window
1237 downcase-expansion tried-list syntax saved-point-2
)
1241 ;; Switch to current completion buffer
1242 (set-cdabbrev-buffer)
1243 ;; Save current buffer state
1244 (setq saved-point
(point)
1245 saved-syntax
(syntax-table))
1246 ;; Restore completion state
1247 (set-syntax-table cmpl-syntax-table
)
1248 (goto-char cdabbrev-current-point
)
1249 ;; Loop looking for completions
1251 ;; This code returns t if it should loop again
1253 (;; search for the string
1254 (search-backward cdabbrev-abbrev-string cdabbrev-stop-point t
)
1255 ;; return nil if the completion is valid
1258 ;; does it start with a separator char ?
1259 (or (= (setq syntax
(char-syntax (preceding-char))) ?
)
1261 ;; symbol char to ignore at end. Are we at end ?
1263 (setq saved-point-2
(point))
1266 (= (char-syntax (preceding-char)) ?
)
1267 (goto-char saved-point-2
)
1269 ;; is the symbol long enough ?
1270 (setq expansion
(symbol-under-point))
1271 ;; have we not tried this one before
1273 ;; See if we've already used it
1274 (setq tried-list cdabbrev-completions-tried
1275 downcase-expansion
(downcase expansion
))
1276 (while (and tried-list
1277 (not (string-equal downcase-expansion
1279 ;; Already tried, don't choose this one
1280 (setq tried-list
(cdr tried-list
))
1282 ;; at this point tried-list will be nil if this
1283 ;; expansion has not yet been tried
1285 (setq expansion nil
)
1290 ;; If already wrapped, then we've failed completely
1294 (goto-char (setq cdabbrev-current-point
1295 (if *cdabbrev-radius
*
1296 (min (point-max) (+ cdabbrev-start-point
*cdabbrev-radius
*))
1299 (setq cdabbrev-wrapped-p t
))
1301 ;; end of while loop
1304 (setq cdabbrev-completions-tried
1305 (cons downcase-expansion cdabbrev-completions-tried
)
1306 cdabbrev-current-point
(point))))
1308 (set-syntax-table saved-syntax
)
1309 (goto-char saved-point
)
1311 ;; If no expansion, go to next window
1313 (t (reset-cdabbrev-window)
1317 ;;; The following must be eval'd in the minibuffer ::
1318 ;;; (reset-cdabbrev "cdat")
1319 ;;; (next-cdabbrev) --> "cdat-simple"
1320 ;;; (next-cdabbrev) --> "cdat-1-2-3-4"
1321 ;;; (next-cdabbrev) --> "CDAT-UPCASE"
1322 ;;; (next-cdabbrev) --> "cdat-wrapping"
1323 ;;; (next-cdabbrev) --> "cdat_start_sym"
1324 ;;; (next-cdabbrev) --> nil
1325 ;;; (next-cdabbrev) --> nil
1326 ;;; (next-cdabbrev) --> nil
1332 ;;;---------------------------------------------------------------------------
1333 ;;; Completion Database
1334 ;;;---------------------------------------------------------------------------
1336 ;;; We use two storage modes for the two search types ::
1337 ;;; 1) Prefix {cmpl-prefix-obarray} for looking up possible completions
1338 ;;; Used by search-completion-next
1339 ;;; the value of the symbol is nil or a cons of head and tail pointers
1340 ;;; 2) Interning {cmpl-obarray} to see if it's in the database
1341 ;;; Used by find-exact-completion, completion-in-database-p
1342 ;;; The value of the symbol is the completion entry
1344 ;;; bad things may happen if this length is changed due to the way
1345 ;;; GNU implements obarrays
1346 (defconst cmpl-obarray-length
511)
1348 (defvar cmpl-prefix-obarray
(make-vector cmpl-obarray-length
0)
1349 "An obarray used to store the downcased completion prefices.
1350 Each symbol is bound to a list of completion entries.")
1352 (defvar cmpl-obarray
(make-vector cmpl-obarray-length
0)
1353 "An obarray used to store the downcased completions.
1354 Each symbol is bound to a single completion entry.")
1356 ;;;-----------------------------------------------
1357 ;;; Completion Entry Structure Definition
1358 ;;;-----------------------------------------------
1360 ;;; A completion entry is a LIST of string, prefix-symbol num-uses, and
1361 ;;; last-use-time (the time the completion was last used)
1362 ;;; last-use-time is T if the string should be kept permanently
1363 ;;; num-uses is incremented everytime the completion is used.
1365 ;;; We chose lists because (car foo) is faster than (aref foo 0) and the
1366 ;;; creation time is about the same.
1370 (defmacro completion-string
(completion-entry)
1371 (list 'car completion-entry
))
1373 (defmacro completion-num-uses
(completion-entry)
1374 ;; "The number of times it has used. Used to decide whether to save
1376 (list 'car
(list 'cdr completion-entry
)))
1378 (defmacro completion-last-use-time
(completion-entry)
1379 ;; "The time it was last used. In hours since 1900. Used to decide
1380 ;; whether to save it. T if one should always save it."
1381 (list 'nth
2 completion-entry
))
1383 (defmacro completion-source
(completion-entry)
1384 (list 'nth
3 completion-entry
))
1387 (defmacro set-completion-string
(completion-entry string
)
1388 (list 'setcar completion-entry string
))
1390 (defmacro set-completion-num-uses
(completion-entry num-uses
)
1391 (list 'setcar
(list 'cdr completion-entry
) num-uses
))
1393 (defmacro set-completion-last-use-time
(completion-entry last-use-time
)
1394 (list 'setcar
(list 'cdr
(list 'cdr completion-entry
)) last-use-time
))
1397 (defun make-completion (string)
1398 "Returns a list of a completion entry."
1399 (list (list string
0 nil current-completion-source
)))
1402 ;;(defmacro cmpl-prefix-entry-symbol (completion-entry)
1403 ;; (list 'car (list 'cdr completion-entry)))
1407 ;;;-----------------------------------------------
1408 ;;; Prefix symbol entry definition
1409 ;;;-----------------------------------------------
1410 ;;; A cons of (head . tail)
1414 (defmacro cmpl-prefix-entry-head
(prefix-entry)
1415 (list 'car prefix-entry
))
1417 (defmacro cmpl-prefix-entry-tail
(prefix-entry)
1418 (list 'cdr prefix-entry
))
1422 (defmacro set-cmpl-prefix-entry-head
(prefix-entry new-head
)
1423 (list 'setcar prefix-entry new-head
))
1425 (defmacro set-cmpl-prefix-entry-tail
(prefix-entry new-tail
)
1426 (list 'setcdr prefix-entry new-tail
))
1430 (defun make-cmpl-prefix-entry (completion-entry-list)
1431 "Makes a new prefix entry containing only completion-entry."
1432 (cons completion-entry-list completion-entry-list
))
1434 ;;;-----------------------------------------------
1435 ;;; Completion Database - Utilities
1436 ;;;-----------------------------------------------
1438 (defun clear-all-completions ()
1439 "Initializes the completion storage. All existing completions are lost."
1441 (setq cmpl-prefix-obarray
(make-vector cmpl-obarray-length
0))
1442 (setq cmpl-obarray
(make-vector cmpl-obarray-length
0))
1443 (cmpl-statistics-block
1444 (record-clear-all-completions))
1447 (defun list-all-completions ()
1448 "Returns a list of all the known completion entries."
1449 (let ((return-completions nil
))
1450 (mapatoms 'list-all-completions-1 cmpl-prefix-obarray
)
1451 return-completions
))
1453 (defun list-all-completions-1 (prefix-symbol)
1454 (if (boundp prefix-symbol
)
1455 (setq return-completions
1456 (append (cmpl-prefix-entry-head (symbol-value prefix-symbol
))
1457 return-completions
))))
1459 (defun list-all-completions-by-hash-bucket ()
1460 "Returns a list of lists of all the known completion entries organized by
1462 (let ((return-completions nil
))
1463 (mapatoms 'list-all-completions-by-hash-bucket-1 cmpl-prefix-obarray
)
1464 return-completions
))
1466 (defun list-all-completions-by-hash-bucket-1 (prefix-symbol)
1467 (if (boundp prefix-symbol
)
1468 (setq return-completions
1469 (cons (cmpl-prefix-entry-head (symbol-value prefix-symbol
))
1470 return-completions
))))
1473 ;;;-----------------------------------------------
1474 ;;; Updating the database
1475 ;;;-----------------------------------------------
1477 ;;; These are the internal functions used to update the datebase
1480 (defvar completion-to-accept nil
)
1481 ;;"Set to a string that is pending its acceptance."
1482 ;; this checked by the top level reading functions
1484 (defvar cmpl-db-downcase-string nil
)
1485 ;; "Setup by find-exact-completion, etc. The given string, downcased."
1486 (defvar cmpl-db-symbol nil
)
1487 ;; "The interned symbol corresponding to cmpl-db-downcase-string.
1488 ;; Set up by cmpl-db-symbol."
1489 (defvar cmpl-db-prefix-symbol nil
)
1490 ;; "The interned prefix symbol corresponding to cmpl-db-downcase-string."
1491 (defvar cmpl-db-entry nil
)
1492 (defvar cmpl-db-debug-p nil
1493 "Set to T if you want to debug the database.")
1496 (defun find-exact-completion (string)
1497 "Returns the completion entry for string or nil.
1498 Sets up cmpl-db-downcase-string and cmpl-db-symbol."
1499 (and (boundp (setq cmpl-db-symbol
1500 (intern (setq cmpl-db-downcase-string
(downcase string
))
1502 (symbol-value cmpl-db-symbol
)
1505 (defun find-cmpl-prefix-entry (prefix-string)
1506 "Returns the prefix entry for string.
1507 Sets cmpl-db-prefix-symbol.
1508 Prefix-string must be exactly *completion-prefix-min-length* long
1509 and downcased. Sets up cmpl-db-prefix-symbol."
1510 (and (boundp (setq cmpl-db-prefix-symbol
1511 (intern prefix-string cmpl-prefix-obarray
)))
1512 (symbol-value cmpl-db-prefix-symbol
)))
1514 (defvar inside-locate-completion-entry nil
)
1515 ;; used to trap lossage in silent error correction
1517 (defun locate-completion-entry (completion-entry prefix-entry
)
1518 "Locates the completion entry.
1519 Returns a pointer to the element before the completion entry or nil if
1520 the completion entry is at the head.
1521 Must be called after find-exact-completion."
1522 (let ((prefix-list (cmpl-prefix-entry-head prefix-entry
))
1526 ((not (eq (car prefix-list
) completion-entry
))
1527 ;; not already at head
1528 (while (and prefix-list
1529 (not (eq completion-entry
1530 (car (setq next-prefix-list
(cdr prefix-list
)))
1532 (setq prefix-list next-prefix-list
))
1535 ;; Didn't find it. Database is messed up.
1537 ;; not found, error if debug mode
1538 (error "Completion entry exists but not on prefix list - %s"
1540 (inside-locate-completion-entry
1541 ;; recursive error: really scrod
1542 (locate-completion-db-error))
1545 (set cmpl-db-symbol nil
)
1547 (locate-completion-entry-retry completion-entry
)
1550 (defun locate-completion-entry-retry (old-entry)
1551 (let ((inside-locate-completion-entry t
))
1552 (add-completion (completion-string old-entry
)
1553 (completion-num-uses old-entry
)
1554 (completion-last-use-time old-entry
))
1555 (let ((cmpl-entry (find-exact-completion (completion-string old-entry
)))
1558 (find-cmpl-prefix-entry
1559 (substring cmpl-db-downcase-string
1560 0 *completion-prefix-min-length
*))))
1562 (if (and cmpl-entry pref-entry
)
1564 (locate-completion-entry cmpl-entry pref-entry
)
1566 (locate-completion-db-error))
1569 (defun locate-completion-db-error ()
1570 ;; recursive error: really scrod
1571 (error "Completion database corrupted. Try M-x clear-all-completions. Send bug report.")
1575 (defun add-completion-to-tail-if-new (string)
1576 "If STRING is not in the database add it to appropriate prefix list.
1577 STRING is added to the end of the approppriate prefix list with
1578 num-uses = 0. The database is unchanged if it is there. STRING must be
1579 longer than *completion-prefix-min-length*.
1580 This must be very fast.
1581 Returns the completion entry."
1582 (or (find-exact-completion string
)
1584 (let (;; create an entry
1585 (entry (make-completion string
))
1587 (prefix-entry (find-cmpl-prefix-entry
1588 (substring cmpl-db-downcase-string
0
1590 *completion-prefix-min-length
*))))
1592 ;; The next two forms should happen as a unit (atomically) but
1593 ;; no fatal errors should result if that is not the case.
1595 ;; These two should be atomic, but nothing fatal will happen
1597 (setcdr (cmpl-prefix-entry-tail prefix-entry
) entry
)
1598 (set-cmpl-prefix-entry-tail prefix-entry entry
))
1600 (set cmpl-db-prefix-symbol
(make-cmpl-prefix-entry entry
))
1603 (cmpl-statistics-block
1604 (note-added-completion))
1606 (set cmpl-db-symbol
(car entry
))
1609 (defun add-completion-to-head (string)
1610 "If STRING is not in the database, add it to prefix list.
1611 STRING is added to the head of the approppriate prefix list. Otherwise
1612 it is moved to the head of the list. STRING must be longer than
1613 *completion-prefix-min-length*.
1614 Updates the saved string with the supplied string.
1615 This must be very fast.
1616 Returns the completion entry."
1617 ;; Handle pending acceptance
1618 (if completion-to-accept
(accept-completion))
1619 ;; test if already in database
1620 (if (setq cmpl-db-entry
(find-exact-completion string
))
1622 (let* ((prefix-entry (find-cmpl-prefix-entry
1623 (substring cmpl-db-downcase-string
0
1625 *completion-prefix-min-length
*))))
1626 (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry
))
1627 (cmpl-ptr (cdr splice-ptr
))
1630 (set-completion-string cmpl-db-entry string
)
1631 ;; move to head (if necessary)
1633 ;; These should all execute atomically but it is not fatal if
1636 (or (setcdr splice-ptr
(cdr cmpl-ptr
))
1637 ;; fix up tail if necessary
1638 (set-cmpl-prefix-entry-tail prefix-entry splice-ptr
))
1639 ;; splice in at head
1640 (setcdr cmpl-ptr
(cmpl-prefix-entry-head prefix-entry
))
1641 (set-cmpl-prefix-entry-head prefix-entry cmpl-ptr
)
1645 (let (;; create an entry
1646 (entry (make-completion string
))
1648 (prefix-entry (find-cmpl-prefix-entry
1649 (substring cmpl-db-downcase-string
0
1651 *completion-prefix-min-length
*))))
1654 ;; Splice in at head
1655 (setcdr entry
(cmpl-prefix-entry-head prefix-entry
))
1656 (set-cmpl-prefix-entry-head prefix-entry entry
))
1658 ;; Start new prefix entry
1659 (set cmpl-db-prefix-symbol
(make-cmpl-prefix-entry entry
))
1662 (cmpl-statistics-block
1663 (note-added-completion))
1664 ;; Add it to the symbol
1665 (set cmpl-db-symbol
(car entry
))
1668 (defun delete-completion (string)
1669 "Deletes the completion from the database.
1670 String must be longer than *completion-prefix-min-length*."
1671 ;; Handle pending acceptance
1672 (if completion-to-accept
(accept-completion))
1673 (if (setq cmpl-db-entry
(find-exact-completion string
))
1675 (let* ((prefix-entry (find-cmpl-prefix-entry
1676 (substring cmpl-db-downcase-string
0
1678 *completion-prefix-min-length
*))))
1679 (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry
))
1681 ;; delete symbol reference
1682 (set cmpl-db-symbol nil
)
1683 ;; remove from prefix list
1686 (or (setcdr splice-ptr
(cdr (cdr splice-ptr
)))
1687 ;; fix up tail if necessary
1688 (set-cmpl-prefix-entry-tail prefix-entry splice-ptr
))
1692 (or (set-cmpl-prefix-entry-head
1693 prefix-entry
(cdr (cmpl-prefix-entry-head prefix-entry
)))
1694 ;; List is now empty
1695 (set cmpl-db-prefix-symbol nil
))
1697 (cmpl-statistics-block
1698 (note-completion-deleted))
1700 (error "Unknown completion: %s. Couldn't delete it." string
)
1704 ;;; - Add and Find -
1705 ;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
1706 ;;; (find-exact-completion "banana") --> ("banana" 0 nil 0)
1707 ;;; (find-exact-completion "bana") --> nil
1708 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
1709 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
1710 ;;; (add-completion-to-head "banish") --> ("banish" 0 nil 0)
1711 ;;; (find-exact-completion "banish") --> ("banish" 0 nil 0)
1712 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
1713 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
1714 ;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
1715 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
1716 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
1719 ;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
1720 ;;; (delete-completion "banner")
1721 ;;; (find-exact-completion "banner") --> nil
1722 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
1723 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
1724 ;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
1725 ;;; (delete-completion "banana")
1726 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...))
1727 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
1728 ;;; (delete-completion "banner")
1729 ;;; (delete-completion "banish")
1730 ;;; (find-cmpl-prefix-entry "ban") --> nil
1731 ;;; (delete-completion "banner") --> error
1734 ;;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0)
1735 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
1736 ;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
1737 ;;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0)
1738 ;;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...))
1739 ;;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...))
1743 ;;;---------------------------------------------------------------------------
1744 ;;; Database Update :: Interface level routines
1745 ;;;---------------------------------------------------------------------------
1747 ;;; These lie on top of the database ref. functions but below the standard
1748 ;;; user interface level
1751 (defun interactive-completion-string-reader (prompt)
1752 (let* ((default (symbol-under-or-before-point))
1755 (format "%s: (default: %s) " prompt default
)
1756 (format "%s: " prompt
))
1758 (read (completing-read new-prompt cmpl-obarray
))
1760 (if (zerop (length read
)) (setq read
(or default
"")))
1764 (defun check-completion-length (string)
1765 (if (< (length string
) *completion-min-length
*)
1766 (error "The string \"%s\" is too short to be saved as a completion."
1770 (defun add-completion (string &optional num-uses last-use-time
)
1771 "If the string is not there, it is added to the head of the completion list.
1772 Otherwise, it is moved to the head of the list.
1773 The completion is altered appropriately if num-uses and/or last-use-time is
1775 (interactive (interactive-completion-string-reader "Completion to add"))
1776 (check-completion-length string
)
1777 (let* ((current-completion-source (if (interactive-p)
1778 cmpl-source-interactive
1779 current-completion-source
))
1780 (entry (add-completion-to-head string
)))
1782 (if num-uses
(set-completion-num-uses entry num-uses
))
1784 (set-completion-last-use-time entry last-use-time
))
1787 (defun add-permanent-completion (string)
1788 "Adds string if it isn't already there and and makes it a permanent string."
1790 (interactive-completion-string-reader "Completion to add permanently"))
1791 (let ((current-completion-source (if (interactive-p)
1792 cmpl-source-interactive
1793 current-completion-source
))
1795 (add-completion string nil t
)
1798 (defun kill-completion (string)
1799 (interactive (interactive-completion-string-reader "Completion to kill"))
1800 (check-completion-length string
)
1801 (delete-completion string
)
1804 (defun accept-completion ()
1805 "Accepts the pending completion in completion-to-accept.
1806 This bumps num-uses. Called by add-completion-to-head and
1807 completion-search-reset."
1808 (let ((string completion-to-accept
)
1809 ;; if this is added afresh here, then it must be a cdabbrev
1810 (current-completion-source cmpl-source-cdabbrev
)
1813 (setq completion-to-accept nil
)
1814 (setq entry
(add-completion-to-head string
))
1815 (set-completion-num-uses entry
(1+ (completion-num-uses entry
)))
1816 (setq cmpl-completions-accepted-p t
)
1819 (defun use-completion-under-point ()
1820 "Adds the completion symbol underneath the point into the completion buffer."
1821 (let ((string (and *completep
* (symbol-under-point)))
1822 (current-completion-source cmpl-source-cursor-moves
))
1823 (if string
(add-completion-to-head string
))))
1825 (defun use-completion-before-point ()
1826 "Adds the completion symbol before point into
1827 the completion buffer."
1828 (let ((string (and *completep
* (symbol-before-point)))
1829 (current-completion-source cmpl-source-cursor-moves
))
1830 (if string
(add-completion-to-head string
))))
1832 (defun use-completion-under-or-before-point ()
1833 "Adds the completion symbol before point into the completion buffer."
1834 (let ((string (and *completep
* (symbol-under-or-before-point)))
1835 (current-completion-source cmpl-source-cursor-moves
))
1836 (if string
(add-completion-to-head string
))))
1838 (defun use-completion-before-separator ()
1839 "Adds the completion symbol before point into the completion buffer.
1840 Completions added this way will automatically be saved if
1841 *separator-character-uses-completion-p* is non-nil."
1842 (let ((string (and *completep
* (symbol-before-point)))
1843 (current-completion-source cmpl-source-separator
)
1845 (cmpl-statistics-block
1846 (note-separator-character string
)
1849 (setq entry
(add-completion-to-head string
))
1850 (when (and *separator-character-uses-completion-p
*
1851 (zerop (completion-num-uses entry
)))
1852 (set-completion-num-uses entry
1)
1853 (setq cmpl-completions-accepted-p t
)
1858 ;;; - Add and Find -
1859 ;;; (add-completion "banana" 5 10)
1860 ;;; (find-exact-completion "banana") --> ("banana" 5 10 0)
1861 ;;; (add-completion "banana" 6)
1862 ;;; (find-exact-completion "banana") --> ("banana" 6 10 0)
1863 ;;; (add-completion "banish")
1864 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
1867 ;;; (setq completion-to-accept "banana")
1868 ;;; (accept-completion)
1869 ;;; (find-exact-completion "banana") --> ("banana" 7 10)
1870 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
1871 ;;; (setq completion-to-accept "banish")
1872 ;;; (add-completion "banner")
1873 ;;; (car (find-cmpl-prefix-entry "ban"))
1874 ;;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...))
1877 ;;; (kill-completion "banish")
1878 ;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...))
1881 ;;;---------------------------------------------------------------------------
1882 ;;; Searching the database
1883 ;;;---------------------------------------------------------------------------
1884 ;;; Functions outside this block must call completion-search-reset followed
1885 ;;; by calls to completion-search-next or completion-search-peek
1888 ;;; Status variables
1889 ;; Commented out to improve loading speed
1890 (defvar cmpl-test-string
"")
1891 ;; "The current string used by completion-search-next."
1892 (defvar cmpl-test-regexp
"")
1893 ;; "The current regexp used by completion-search-next.
1894 ;; (derived from cmpl-test-string)"
1895 (defvar cmpl-last-index
0)
1896 ;; "The last index that completion-search-next was called with."
1897 (defvar cmpl-cdabbrev-reset-p nil
)
1898 ;; "Set to t when cdabbrevs have been reset."
1899 (defvar cmpl-next-possibilities nil
)
1900 ;; "A pointer to the element BEFORE the next set of possible completions.
1901 ;; cadr of this is the cmpl-next-possibility"
1902 (defvar cmpl-starting-possibilities nil
)
1903 ;; "The initial list of starting possibilities."
1904 (defvar cmpl-next-possibility nil
)
1905 ;; "The cached next possibility."
1906 (defvar cmpl-tried-list nil
)
1907 ;; "A downcased list of all the completions we have tried."
1910 (defun completion-search-reset (string)
1911 "Given a string, sets up the get-completion and completion-search-next functions.
1912 String must be longer than *completion-prefix-min-length*."
1913 (if completion-to-accept
(accept-completion))
1914 (setq cmpl-starting-possibilities
1915 (cmpl-prefix-entry-head
1916 (find-cmpl-prefix-entry (downcase (substring string
0 3))))
1917 cmpl-test-string string
1918 cmpl-test-regexp
(concat (regexp-quote string
) "."))
1919 (completion-search-reset-1)
1922 (defun completion-search-reset-1 ()
1923 (setq cmpl-next-possibilities cmpl-starting-possibilities
1924 cmpl-next-possibility nil
1925 cmpl-cdabbrev-reset-p nil
1930 (defun completion-search-next (index)
1931 "Returns the next completion entry.
1932 If index is out of sequence it resets and starts from the top.
1933 If there are no more entries it tries cdabbrev and returns only a string."
1935 ((= index
(setq cmpl-last-index
(1+ cmpl-last-index
)))
1936 (completion-search-peek t
))
1938 (completion-search-reset-1)
1939 (setq cmpl-last-index index
)
1940 ;; reverse the possibilities list
1941 (setq cmpl-next-possibilities
(reverse cmpl-starting-possibilities
))
1942 ;; do a "normal" search
1943 (while (and (completion-search-peek nil
)
1944 (minusp (setq index
(1+ index
))))
1945 (setq cmpl-next-possibility nil
)
1947 (cond ((not cmpl-next-possibilities
))
1948 ;; If no more possibilities, leave it that way
1949 ((= -
1 cmpl-last-index
)
1950 ;; next completion is at index 0. reset next-possibility list
1951 ;; to start at beginning
1952 (setq cmpl-next-possibilities cmpl-starting-possibilities
))
1954 ;; otherwise point to one before current
1955 (setq cmpl-next-possibilities
1956 (nthcdr (- (length cmpl-starting-possibilities
)
1957 (length cmpl-next-possibilities
))
1958 cmpl-starting-possibilities
))
1961 ;; non-negative index, reset and search
1963 (completion-search-reset-1)
1964 (setq cmpl-last-index index
)
1965 (while (and (completion-search-peek t
)
1966 (not (minusp (setq index
(1- index
)))))
1967 (setq cmpl-next-possibility nil
)
1971 cmpl-next-possibility
1972 (setq cmpl-next-possibility nil
)
1976 (defun completion-search-peek (use-cdabbrev)
1977 "Returns the next completion entry without actually moving the pointers.
1978 Calling this again or calling completion-search-next will result in the same
1979 string being returned. Depends on case-fold-search.
1980 If there are no more entries it tries cdabbrev and then returns only a string."
1982 ;; return the cached value if we have it
1983 (cmpl-next-possibility)
1984 ((and cmpl-next-possibilities
1985 ;; still a few possibilities left
1988 (and (not (eq 0 (string-match cmpl-test-regexp
1989 (completion-string (car cmpl-next-possibilities
)))))
1990 (setq cmpl-next-possibilities
(cdr cmpl-next-possibilities
))
1992 cmpl-next-possibilities
1995 (setq cmpl-next-possibility
(car cmpl-next-possibilities
)
1996 cmpl-tried-list
(cons (downcase (completion-string cmpl-next-possibility
))
1998 cmpl-next-possibilities
(cdr cmpl-next-possibilities
)
2000 cmpl-next-possibility
)
2002 ;; unsuccessful, use cdabbrev
2003 (cond ((not cmpl-cdabbrev-reset-p
)
2004 (reset-cdabbrev cmpl-test-string cmpl-tried-list
)
2005 (setq cmpl-cdabbrev-reset-p t
)
2007 (setq cmpl-next-possibility
(next-cdabbrev))
2009 ;; Completely unsuccessful, return nil
2013 ;;; - Add and Find -
2014 ;;; (add-completion "banana")
2015 ;;; (completion-search-reset "ban")
2016 ;;; (completion-search-next 0) --> "banana"
2018 ;;; - Discrimination -
2019 ;;; (add-completion "cumberland")
2020 ;;; (add-completion "cumberbund")
2022 ;;; (completion-search-reset "cumb")
2023 ;;; (completion-search-peek t) --> "cumberbund"
2024 ;;; (completion-search-next 0) --> "cumberbund"
2025 ;;; (completion-search-peek t) --> "cumberland"
2026 ;;; (completion-search-next 1) --> "cumberland"
2027 ;;; (completion-search-peek nil) --> nil
2028 ;;; (completion-search-next 2) --> "cumbering" {cdabbrev}
2029 ;;; (completion-search-next 3) --> nil or "cumming"{depends on context}
2030 ;;; (completion-search-next 1) --> "cumberland"
2031 ;;; (completion-search-peek t) --> "cumbering" {cdabbrev}
2034 ;;; (completion-search-next 1) --> "cumberland"
2035 ;;; (setq completion-to-accept "cumberland")
2036 ;;; (completion-search-reset "foo")
2037 ;;; (completion-search-reset "cum")
2038 ;;; (completion-search-next 0) --> "cumberland"
2041 ;;; (kill-completion "cumberland")
2043 ;;; (completion-search-reset "cum")
2044 ;;; (completion-search-next 0) --> "cumberbund"
2045 ;;; (completion-search-next 1) --> "cummings"
2047 ;;; - Ignoring Capitalization -
2048 ;;; (completion-search-reset "CuMb")
2049 ;;; (completion-search-next 0) --> "cumberbund"
2053 ;;;-----------------------------------------------
2055 ;;;-----------------------------------------------
2057 (defun completion-mode ()
2058 "Toggles whether or not new words are added to the database."
2060 (setq *completep
* (not *completep
*))
2061 (message "Completion mode is now %s." (if *completep
* "ON" "OFF"))
2064 (defvar cmpl-current-index
0)
2065 (defvar cmpl-original-string nil
)
2066 (defvar cmpl-last-insert-location -
1)
2067 (defvar cmpl-leave-point-at-start nil
)
2069 (defun complete (&optional arg
)
2070 "Inserts a completion at point.
2071 Point is left at end. Consective calls rotate through all possibilities.
2073 control-u :: leave the point at the beginning of the completion rather
2075 a number :: rotate through the possible completions by that amount
2076 `-' :: same as -1 (insert previous completion)
2077 {See the comments at the top of completion.el for more info.}
2080 ;;; Set up variables
2081 (cond ((eq last-command this-command
)
2083 (delete-region cmpl-last-insert-location
(point))
2084 ;; get next completion
2085 (setq cmpl-current-index
(+ cmpl-current-index
(or arg
1)))
2088 (if (not cmpl-initialized-p
)
2089 (initialize-completions)) ;; make sure everything's loaded
2090 (cond ((consp current-prefix-arg
) ;; control-u
2092 (setq cmpl-leave-point-at-start t
)
2095 (setq cmpl-leave-point-at-start nil
)
2098 (setq cmpl-original-string
(symbol-before-point-for-complete))
2099 (cond ((not cmpl-original-string
)
2100 (setq this-command
'failed-complete
)
2101 (error "To complete, the point must be after a symbol at least %d character long."
2102 *completion-prefix-min-length
*)))
2104 (setq cmpl-current-index
(if current-prefix-arg arg
0))
2106 (cmpl-statistics-block
2107 (note-complete-entered-afresh cmpl-original-string
))
2109 (completion-search-reset cmpl-original-string
)
2110 ;; erase what we've got
2111 (delete-region cmpl-symbol-start cmpl-symbol-end
)
2114 ;; point is at the point to insert the new symbol
2115 ;; Get the next completion
2116 (let* ((print-status-p
2117 (and (>= (cmpl19-baud-rate) *print-next-completion-speed-threshold
*)
2118 (not (minibuffer-window-selected-p))))
2119 (insert-point (point))
2120 (entry (completion-search-next cmpl-current-index
))
2123 ;; entry is either a completion entry or a string (if cdabbrev)
2127 ;; Setup for proper case
2128 (setq string
(if (stringp entry
)
2129 entry
(completion-string entry
)))
2130 (setq string
(cmpl-merge-string-cases
2131 string cmpl-original-string
))
2135 (setq completion-to-accept string
)
2136 ;; fixup and cache point
2137 (cond (cmpl-leave-point-at-start
2138 (setq cmpl-last-insert-location
(point))
2139 (goto-char insert-point
))
2141 (setq cmpl-last-insert-location insert-point
))
2144 (cmpl-statistics-block
2145 (note-complete-inserted entry cmpl-current-index
))
2146 ;; Done ! cmpl-stat-complete-successful
2147 ;;display the next completion
2149 ((and print-status-p
2150 ;; This updates the display and only prints if there
2154 (completion-search-peek
2155 *print-next-completion-does-cdabbrev-search-p
*)))
2156 (setq string
(if (stringp entry
)
2157 entry
(completion-string entry
)))
2158 (setq string
(cmpl-merge-string-cases
2159 string cmpl-original-string
))
2160 (message "Next completion: %s" string
)
2163 (t;; none found, insert old
2164 (insert cmpl-original-string
)
2165 ;; Don't accept completions
2166 (setq completion-to-accept nil
)
2168 (if (and print-status-p
(cmpl19-sit-for 0))
2169 (message "No %scompletions."
2170 (if (eq this-command last-command
) "more " "")))
2172 (cmpl-statistics-block
2173 (record-complete-failed cmpl-current-index
))
2174 ;; Pretend that we were never here
2175 (setq this-command
'failed-complete
)
2178 ;;;-----------------------------------------------
2179 ;;; "Complete" Key Keybindings
2180 ;;;-----------------------------------------------
2182 ;;; Complete key definition
2183 ;;; These define c-return and meta-return
2184 ;;; In any case you really want to bind this to a single keystroke
2185 (if (fboundp 'key-for-others-chord
)
2187 ;; this can fail if some of the prefix chars. are already used
2188 ;; as commands (this happens on wyses)
2189 (global-set-key (key-for-others-chord "return" '(control)) 'complete
)
2192 (if (fboundp 'gmacs-keycode
)
2193 (global-set-key (gmacs-keycode "return" '(control)) 'complete
)
2195 (global-set-key "\M-\r" 'complete
)
2198 ;;; (add-completion "cumberland")
2199 ;;; (add-completion "cumberbund")
2206 ;;;---------------------------------------------------------------------------
2207 ;;; Parsing definitions from files into the database
2208 ;;;---------------------------------------------------------------------------
2210 ;;;-----------------------------------------------
2211 ;;; Top Level functions ::
2212 ;;;-----------------------------------------------
2215 (defun add-completions-from-file (file)
2216 "Parses all the definition names from a Lisp mode file and adds them to the
2217 completion database."
2218 (interactive "fFile: ")
2219 (setq file
(if (fboundp 'expand-file-name-defaulting
)
2220 (expand-file-name-defaulting file
)
2221 (expand-file-name file
)))
2222 (let* ((buffer (get-file-buffer file
))
2223 (buffer-already-there-p buffer
)
2225 (when (not buffer-already-there-p
)
2226 (let ((*modes-for-completion-find-file-hook
* nil
))
2227 (setq buffer
(find-file-noselect file
))
2232 (add-completions-from-buffer)
2234 (when (not buffer-already-there-p
)
2235 (kill-buffer buffer
))
2238 (defun add-completions-from-buffer ()
2240 (let ((current-completion-source cmpl-source-file-parsing
)
2242 (cmpl-statistics-block
2243 (aref completion-add-count-vector cmpl-source-file-parsing
)))
2246 (cond ((memq major-mode
'(emacs-lisp-mode lisp-mode
))
2247 (add-completions-from-lisp-buffer)
2250 ((memq major-mode
'(c-mode))
2251 (add-completions-from-c-buffer)
2255 (error "Do not know how to parse completions in %s buffers."
2258 (cmpl-statistics-block
2259 (record-cmpl-parse-file
2261 (- (aref completion-add-count-vector cmpl-source-file-parsing
)
2266 (defun cmpl-find-file-hook ()
2268 (cond ((and (memq major-mode
'(emacs-lisp-mode lisp-mode
))
2269 (memq 'lisp
*modes-for-completion-find-file-hook
*)
2271 (add-completions-from-buffer))
2272 ((and (memq major-mode
'(c-mode))
2273 (memq 'c
*modes-for-completion-find-file-hook
*)
2275 (add-completions-from-buffer)
2279 (pushnew 'cmpl-find-file-hook find-file-hooks
)
2281 ;;;-----------------------------------------------
2282 ;;; Tags Table Completions
2283 ;;;-----------------------------------------------
2285 (defun add-completions-from-tags-table ()
2286 ;; Inspired by eero@media-lab.media.mit.edu
2287 "Add completions from the current tags-table-buffer."
2289 (visit-tags-table-buffer) ;this will prompt if no tags-table
2291 (goto-char (point-min))
2295 (search-forward "\177")
2297 (and (setq string
(symbol-under-point))
2298 (add-completion-to-tail-if-new string
))
2305 ;;;-----------------------------------------------
2306 ;;; Lisp File completion parsing
2307 ;;;-----------------------------------------------
2308 ;;; This merely looks for phrases beginning with (def.... or
2309 ;;; (package:def ... and takes the next word.
2311 ;;; We tried using forward-lines and explicit searches but the regexp technique
2312 ;;; was faster. (About 100K characters per second)
2314 (defconst *lisp-def-regexp
*
2315 "\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
2316 "A regexp that searches for lisp definition form."
2320 ;;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8
2321 ;;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9
2322 ;;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10
2323 ;;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9
2325 (defun add-completions-from-lisp-buffer ()
2326 "Parses all the definition names from a Lisp mode buffer and adds them to
2327 the completion database."
2329 ;;; Sun-3/280 - 1500 to 3000 lines of lisp code per second
2332 (goto-char (point-min))
2335 (re-search-forward *lisp-def-regexp
*)
2336 (and (setq string
(symbol-under-point))
2337 (add-completion-to-tail-if-new string
))
2343 ;;;-----------------------------------------------
2344 ;;; C file completion parsing
2345 ;;;-----------------------------------------------
2347 ;;; Looks for #define or [<storage class>] [<type>] <name>{,<name>}
2348 ;;; or structure, array or pointer defs.
2349 ;;; It gets most of the definition names.
2351 ;;; As you might suspect by now, we use some symbol table hackery
2353 ;;; Symbol separator chars (have whitespace syntax) --> , ; * = (
2354 ;;; Opening char --> [ {
2355 ;;; Closing char --> ] }
2356 ;;; openning and closing must be skipped over
2357 ;;; Whitespace chars (have symbol syntax)
2358 ;;; Everything else has word syntax
2360 (defun make-c-def-completion-syntax-table ()
2361 (let ((table (make-vector 256 0))
2362 (whitespace-chars '(? ?
\n ?
\t ?
\f ?
\v ?
\r))
2363 ;; unforunately the ?( causes the parens to appear unbalanced
2364 (separator-chars '(?
, ?
* ?
= ?\
( ?\
;
2367 ;; default syntax is whitespace
2369 (modify-syntax-entry i
"w" table
))
2370 (dolist (char whitespace-chars
)
2371 (modify-syntax-entry char
"_" table
))
2372 (dolist (char separator-chars
)
2373 (modify-syntax-entry char
" " table
))
2374 (modify-syntax-entry ?\
[ "(]" table
)
2375 (modify-syntax-entry ?\
{ "(}" table
)
2376 (modify-syntax-entry ?\
] ")[" table
)
2377 (modify-syntax-entry ?\
} "){" table
)
2380 (defconst cmpl-c-def-syntax-table
(make-c-def-completion-syntax-table))
2383 (defconst *c-def-regexp
*
2384 ;; This stops on lines with possible definitions
2386 ;; This stops after the symbol to add.
2387 ;;"\n\\(#define\\s +.\\|\\(\\(\\w\\|\\s_\\)+\\b\\s *\\)+[(;,[*{=]\\)"
2388 ;; This stops before the symbol to add. {Test cases in parens. below}
2389 ;;"\n\\(\\(\\w\\|\\s_\\)+\\s *(\\|\\(\\(#define\\|auto\\|extern\\|register\\|static\\|int\\|long\\|short\\|unsigned\\|char\\|void\\|float\\|double\\|enum\\|struct\\|union\\|typedef\\)\\s +\\)+\\)"
2390 ;; this simple version picks up too much extraneous stuff
2391 ;; "\n\\(\\w\\|\\s_\\|#\\)\\B"
2392 "A regexp that searches for a definition form."
2395 ;(defconst *c-cont-regexp*
2396 ; "\\(\\w\\|\\s_\\)+\\b\\s *\\({\\|\\(\\[[0-9\t ]*\\]\\s *\\)*,\\(*\\|\\s \\)*\\b\\)"
2397 ; "This regexp should be used in a looking-at to parse for lists of variables.")
2399 ;(defconst *c-struct-regexp*
2400 ; "\\(*\\|\\s \\)*\\b"
2401 ; "This regexp should be used to test whether a symbol follows a structure definition.")
2403 ;(defun test-c-def-regexp (regexp string)
2404 ; (and (eq 0 (string-match regexp string)) (match-end 0))
2408 ;;; (test-c-def-regexp *c-def-regexp* "\n#define foo") -> 10 (9)
2409 ;;; (test-c-def-regexp *c-def-regexp* "\nfoo (x, y) {") -> 6 (6)
2410 ;;; (test-c-def-regexp *c-def-regexp* "\nint foo (x, y)") -> 10 (5)
2411 ;;; (test-c-def-regexp *c-def-regexp* "\n int foo (x, y)") -> nil
2412 ;;; (test-c-def-regexp *c-cont-regexp* "oo, bar") -> 4
2413 ;;; (test-c-def-regexp *c-cont-regexp* "oo, *bar") -> 5
2414 ;;; (test-c-def-regexp *c-cont-regexp* "a [5][6], bar") -> 10
2415 ;;; (test-c-def-regexp *c-cont-regexp* "oo(x,y)") -> nil
2416 ;;; (test-c-def-regexp *c-cont-regexp* "a [6] ,\t bar") -> 9
2417 ;;; (test-c-def-regexp *c-cont-regexp* "oo {trout =1} my_carp;") -> 14
2418 ;;; (test-c-def-regexp *c-cont-regexp* "truct_p complex foon") -> nil
2420 (defun add-completions-from-c-buffer ()
2421 "Parses all the definition names from a C mode buffer and adds them to the
2422 completion database."
2424 ;; Sun 3/280-- 1250 lines/sec.
2426 (let (string next-point char
2427 (saved-syntax (syntax-table))
2430 (goto-char (point-min))
2431 (catch 'finish-add-completions
2434 ;; we loop here only when scan-sexps fails
2435 ;; (i.e. unbalance exps.)
2436 (set-syntax-table cmpl-c-def-syntax-table
)
2439 (re-search-forward *c-def-regexp
*)
2441 ((= (preceding-char) ?
#)
2442 ;; preprocessor macro, see if it's one we handle
2443 (setq string
(buffer-substring (point) (+ (point) 6)))
2444 (cond ((or (string-equal string
"define")
2445 (string-equal string
"ifdef ")
2447 ;; skip forward over definition symbol
2448 ;; and add it to database
2449 (and (forward-word 2)
2450 (setq string
(symbol-before-point))
2452 (add-completion-to-tail-if-new string
)
2456 (setq next-point
(point))
2459 ;; scan to next separator char.
2460 (setq next-point
(scan-sexps next-point
1))
2462 ;; position the point on the word we want to add
2463 (goto-char next-point
)
2464 (while (= (setq char
(following-char)) ?
*)
2465 ;; handle pointer ref
2466 ;; move to next separator char.
2468 (setq next-point
(scan-sexps (point) 1)))
2472 (if (setq string
(symbol-under-point))
2473 ;; (push string foo)
2474 (add-completion-to-tail-if-new string
)
2475 ;; Local TMC hack (useful for parsing paris.h)
2476 (if (and (looking-at "_AP") ;; "ansi prototype"
2480 (symbol-under-point))
2482 (add-completion-to-tail-if-new string
)
2486 (goto-char next-point
)
2487 ;; (push (format "%c" (following-char)) foo)
2488 (if (= (char-syntax char
) ?\
()
2489 ;; if on an opening delimiter, go to end
2490 (while (= (char-syntax char
) ?\
()
2491 (setq next-point
(scan-sexps next-point
1)
2492 char
(char-after next-point
))
2495 ;; Current char is an end char.
2496 (setq next-point nil
)
2499 (search-failed ;;done
2500 (throw 'finish-add-completions t
)
2503 ;; Check for failure in scan-sexps
2504 (if (or (string-equal (second e
)
2505 "Containing expression ends prematurely")
2506 (string-equal (second e
) "Unbalanced parentheses"))
2507 ;; unbalanced paren., keep going
2510 (message "Error parsing C buffer for completions. Please bug report.")
2511 (throw 'finish-add-completions t
)
2514 (set-syntax-table saved-syntax
)
2518 ;;;---------------------------------------------------------------------------
2520 ;;;---------------------------------------------------------------------------
2522 (defun kill-emacs-save-completions ()
2523 "The version of save-completions-to-file called at kill-emacs time."
2524 (when (and *save-completions-p
* *completep
* cmpl-initialized-p
)
2526 ((not cmpl-completions-accepted-p
)
2527 (message "Completions database has not changed - not writing."))
2529 (save-completions-to-file)
2533 (defconst saved-cmpl-file-header
2534 ";;; Completion Initialization file.
2536 ;;; Format is (<string> . <last-use-time>)
2537 ;;; <string> is the completion
2538 ;;; <last-use-time> is the time the completion was last used
2539 ;;; If it is t, the completion will never be pruned from the file.
2540 ;;; Otherwise it is in hours since 1900.
2543 (defun completion-backup-filename (filename)
2544 (concat filename
".BAK"))
2546 (defun save-completions-to-file (&optional filename
)
2547 "Saves a completion init file.
2548 If file is not specified, then *saved-completions-filename* is used."
2550 (setq filename
(expand-file-name (or filename
*saved-completions-filename
*)))
2551 (when (file-writable-p filename
)
2552 (if (not cmpl-initialized-p
)
2553 (initialize-completions));; make sure everything's loaded
2554 (message "Saving completions to file %s" filename
)
2556 (let* ((trim-versions-without-asking t
)
2557 (kept-old-versions 0)
2558 (kept-new-versions *completion-file-versions-kept
*)
2560 (current-time (cmpl-hours-since-1900))
2564 (backup-filename (completion-backup-filename filename
))
2568 (get-buffer-create " *completion-save-buffer*")
2569 (set-buffer " *completion-save-buffer*")
2570 (setq buffer-file-name filename
)
2572 (when (not (verify-visited-file-modtime (current-buffer)))
2573 ;; file has changed on disk. Bring us up-to-date
2574 (message "Completion file has changed. Merging. . .")
2575 (load-completions-from-file filename t
)
2576 (message "Merging finished. Saving completions to file %s" filename
)
2579 ;; prepare the buffer to be modified
2580 (clear-visited-file-modtime)
2583 (insert (format saved-cmpl-file-header
*completion-version
*))
2584 (dolist (completion (list-all-completions))
2585 (setq total-in-db
(1+ total-in-db
))
2586 (setq last-use-time
(completion-last-use-time completion
))
2587 ;; Update num uses and maybe write completion to a file
2588 (cond ((or;; Write to file if
2590 (and (eq last-use-time t
)
2591 (setq total-perm
(1+ total-perm
)))
2593 (if (plusp (completion-num-uses completion
))
2595 (setq last-use-time current-time
)
2596 ;; or it was saved before and
2598 ;; *saved-completion-retention-time* is nil
2599 (or (not *saved-completion-retention-time
*)
2600 ;; or time since last use is < ...retention-time*
2601 (< (- current-time last-use-time
)
2602 *saved-completion-retention-time
*))
2605 (setq total-saved
(1+ total-saved
))
2606 (insert (prin1-to-string (cons (completion-string completion
)
2607 last-use-time
)) "\n")
2612 (let ((file-exists-p (file-exists-p filename
)))
2614 ;; If file exists . . .
2615 ;; Save a backup(so GNU doesn't screw us when we're out of disk)
2616 ;; (GNU leaves a 0 length file if it gets a disk full error!)
2618 ;; If backup doesn't exit, Rename current to backup
2619 ;; {If backup exists the primary file is probably messed up}
2620 (unless (file-exists-p backup-filename
)
2621 (rename-file filename backup-filename
))
2622 ;; Copy the backup back to the current name
2623 ;; (so versioning works)
2624 (copy-file backup-filename filename t
)
2629 ;; If successful, remove backup
2630 (delete-file backup-filename
)
2633 (set-buffer-modified-p nil
)
2634 (message "Couldn't save completion file %s." filename
)
2636 ;; Reset accepted-p flag
2637 (setq cmpl-completions-accepted-p nil
)
2639 (cmpl-statistics-block
2640 (record-save-completions total-in-db total-perm total-saved
))
2643 (defun autosave-completions ()
2644 (when (and *save-completions-p
* *completep
* cmpl-initialized-p
2645 *completion-auto-save-period
*
2646 (> cmpl-emacs-idle-time
*completion-auto-save-period
*)
2647 cmpl-completions-accepted-p
)
2648 (save-completions-to-file)
2651 (pushnew 'autosave-completions cmpl-emacs-idle-time-hooks
)
2653 (defun load-completions-from-file (&optional filename no-message-p
)
2654 "Loads a completion init file.
2655 If file is not specified, then *saved-completions-filename* is used."
2657 (setq filename
(expand-file-name (or filename
*saved-completions-filename
*)))
2658 (let* ((backup-filename (completion-backup-filename filename
))
2659 (backup-readable-p (file-readable-p backup-filename
))
2661 (when backup-readable-p
(setq filename backup-filename
))
2662 (when (file-readable-p filename
)
2663 (if (not no-message-p
)
2664 (message "Loading completions from %sfile %s . . ."
2665 (if backup-readable-p
"backup " "") filename
))
2667 (get-buffer-create " *completion-save-buffer*")
2668 (set-buffer " *completion-save-buffer*")
2669 (setq buffer-file-name filename
)
2670 ;; prepare the buffer to be modified
2671 (clear-visited-file-modtime)
2674 (let ((insert-okay-p nil
)
2675 (buffer (current-buffer))
2676 (current-time (cmpl-hours-since-1900))
2677 string num-uses entry last-use-time
2678 cmpl-entry cmpl-last-use-time
2679 (current-completion-source cmpl-source-init-file
)
2681 (cmpl-statistics-block
2682 (aref completion-add-count-vector cmpl-source-file-parsing
)))
2683 (total-in-file 0) (total-perm 0)
2685 ;; insert the file into a buffer
2687 (progn (insert-file-contents filename t
)
2688 (setq insert-okay-p t
))
2691 (message "File error trying to load completion file %s."
2695 (goto-char (point-min))
2699 (setq entry
(read buffer
))
2700 (setq total-in-file
(1+ total-in-file
))
2703 (stringp (setq string
(car entry
)))
2705 ((eq (setq last-use-time
(cdr entry
)) 'T
)
2706 ;; handle case sensitivity
2707 (setq total-perm
(1+ total-perm
))
2708 (setq last-use-time t
))
2709 ((eq last-use-time t
)
2710 (setq total-perm
(1+ total-perm
)))
2711 ((integerp last-use-time
))
2715 (setq cmpl-last-use-time
2716 (completion-last-use-time
2718 (add-completion-to-tail-if-new string
))
2720 (if (or (eq last-use-time t
)
2721 (and (> last-use-time
1000);;backcompatibility
2722 (not (eq cmpl-last-use-time t
))
2723 (or (not cmpl-last-use-time
)
2725 (> last-use-time cmpl-last-use-time
))
2727 ;; update last-use-time
2728 (set-completion-last-use-time cmpl-entry last-use-time
)
2732 (message "Error: invalid saved completion - %s"
2733 (prin1-to-string entry
))
2734 ;; try to get back in sync
2735 (search-forward "\n(")
2738 (message "End of file while reading completions.")
2741 (if (= (point) (point-max))
2742 (if (not no-message-p
)
2743 (message "Loading completions from file %s . . . Done."
2745 (message "End of file while reading completions.")
2749 (cmpl-statistics-block
2750 (record-load-completions
2751 total-in-file total-perm
2752 (- (aref completion-add-count-vector cmpl-source-init-file
)
2757 (defun initialize-completions ()
2758 "Loads the default completions file.
2759 Also sets up so that exiting emacs will automatically save the file."
2761 (cond ((not cmpl-initialized-p
)
2762 (load-completions-from-file)
2764 (init-cmpl-emacs-idle-process)
2765 (setq cmpl-initialized-p t
)
2769 ;;;-----------------------------------------------
2770 ;;; Kill EMACS patch
2771 ;;;-----------------------------------------------
2773 (completion-advise kill-emacs
:before
2774 ;; | All completion code should go in here
2776 (kill-emacs-save-completions)
2778 ;; | All completion code should go in here
2779 (cmpl-statistics-block
2780 (record-cmpl-kill-emacs))
2784 ;;;-----------------------------------------------
2785 ;;; Kill region patch
2786 ;;;-----------------------------------------------
2788 ;;; Patched to remove the most recent completion
2789 (defvar $$$cmpl-old-kill-region
(symbol-function 'kill-region
))
2791 (defun kill-region (&optional beg end
)
2792 "Kill between point and mark.
2793 The text is deleted but saved in the kill ring.
2794 The command \\[yank] can retrieve it from there.
2795 /(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
2797 This is the primitive for programs to kill text (as opposed to deleting it).
2798 Supply two arguments, character numbers indicating the stretch of text
2800 Any command that calls this function is a \"kill command\".
2801 If the previous command was also a kill command,
2802 the text killed this time appends to the text killed last time
2803 to make one entry in the kill ring.
2804 Patched to remove the most recent completion."
2806 (cond ((and (eq last-command
'complete
) (eq last-command-char ?\C-w
))
2807 (delete-region (point) cmpl-last-insert-location
)
2808 (insert cmpl-original-string
)
2809 (setq completion-to-accept nil
)
2810 (cmpl-statistics-block
2811 (record-complete-failed))
2815 (setq beg
(min (point) (mark))
2816 end
(max (point) (mark)))
2818 (funcall $$$cmpl-old-kill-region beg end
)
2821 ;;;-----------------------------------------------
2822 ;;; Patches to self-insert-command.
2823 ;;;-----------------------------------------------
2825 ;;; Need 2 versions: generic seperator chars. and space (to get auto fill
2828 ;;; All common separators (eg. space "(" ")" """) characters go through a
2829 ;;; function to add new words to the list of words to complete from:
2830 ;;; COMPLETION-SEPARATOR-SELF-INSERT-COMMAND (arg).
2831 ;;; If the character before this was an alpha-numeric then this adds the
2832 ;;; symbol befoe point to the completion list (using ADD-COMPLETION).
2834 (defun completion-separator-self-insert-command (arg)
2836 (use-completion-before-separator)
2837 (self-insert-command arg
)
2840 (defun completion-separator-self-insert-autofilling (arg)
2842 (use-completion-before-separator)
2843 (self-insert-command arg
)
2844 (and (> (current-column) fill-column
)
2846 (funcall auto-fill-function
))
2849 ;;;-----------------------------------------------
2851 ;;;-----------------------------------------------
2853 ;;; Note that because of the way byte compiling works, none of
2854 ;;; the functions defined with this macro get byte compiled.
2856 (defmacro def-completion-wrapper
(function-name type
&optional new-name
)
2857 "Add a call to update the completion database before function execution.
2858 TYPE is the type of the wrapper to be added. Can be :before or :under."
2859 (completion-advise-1
2860 function-name
':before
2862 (:before
'((use-completion-before-point)))
2863 (:separator
'((use-completion-before-separator)))
2864 (:under
'((use-completion-under-point)))
2866 '((use-completion-under-or-before-point)))
2867 (:minibuffer-separator
2868 '((let ((cmpl-syntax-table cmpl-standard-syntax-table
))
2869 (use-completion-before-separator))))
2874 ;;;(defun foo (x y z) (+ x y z))
2876 ;;;(macroexpand '(def-completion-wrapper foo :under))
2877 ;;;(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)))
2878 ;;;(defun bar (x y z) "Documentation" (+ x y z))
2880 ;;;(macroexpand '(def-completion-wrapper bar :under))
2881 ;;;(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)))
2882 ;;;(defun quuz (x &optional y z) "Documentation" (interactive "P") (+ x y z))
2884 ;;;(macroexpand '(def-completion-wrapper quuz :before))
2885 ;;;(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)))
2888 ;;;---------------------------------------------------------------------------
2889 ;;; Patches to standard keymaps insert completions
2890 ;;;---------------------------------------------------------------------------
2892 ;;;-----------------------------------------------
2894 ;;;-----------------------------------------------
2895 ;;; We've used the completion syntax table given as a guide.
2897 ;;; Global separator chars.
2898 ;;; We left out <tab> because there are too many special cases for it. Also,
2899 ;;; in normal coding it's rarely typed after a word.
2900 (global-set-key " " 'completion-separator-self-insert-autofilling
)
2901 (global-set-key "!" 'completion-separator-self-insert-command
)
2902 (global-set-key "%" 'completion-separator-self-insert-command
)
2903 (global-set-key "^" 'completion-separator-self-insert-command
)
2904 (global-set-key "&" 'completion-separator-self-insert-command
)
2905 (global-set-key "(" 'completion-separator-self-insert-command
)
2906 (global-set-key ")" 'completion-separator-self-insert-command
)
2907 (global-set-key "=" 'completion-separator-self-insert-command
)
2908 (global-set-key "`" 'completion-separator-self-insert-command
)
2909 (global-set-key "|" 'completion-separator-self-insert-command
)
2910 (global-set-key "{" 'completion-separator-self-insert-command
)
2911 (global-set-key "}" 'completion-separator-self-insert-command
)
2912 (global-set-key "[" 'completion-separator-self-insert-command
)
2913 (global-set-key "]" 'completion-separator-self-insert-command
)
2914 (global-set-key ";" 'completion-separator-self-insert-command
)
2915 (global-set-key "\"" 'completion-separator-self-insert-command
)
2916 (global-set-key "'" 'completion-separator-self-insert-command
)
2917 (global-set-key "#" 'completion-separator-self-insert-command
)
2918 (global-set-key "," 'completion-separator-self-insert-command
)
2919 (global-set-key "?" 'completion-separator-self-insert-command
)
2921 ;;; We include period and colon even though they are symbol chars because :
2922 ;;; - in text we want to pick up the last word in a sentence.
2923 ;;; - in C pointer refs. we want to pick up the first symbol
2924 ;;; - it won't make a difference for lisp mode (package names are short)
2925 (global-set-key "." 'completion-separator-self-insert-command
)
2926 (global-set-key ":" 'completion-separator-self-insert-command
)
2929 (define-key lisp-mode-map
"!" 'self-insert-command
)
2930 (define-key lisp-mode-map
"&" 'self-insert-command
)
2931 (define-key lisp-mode-map
"%" 'self-insert-command
)
2932 (define-key lisp-mode-map
"?" 'self-insert-command
)
2933 (define-key lisp-mode-map
"=" 'self-insert-command
)
2934 (define-key lisp-mode-map
"^" 'self-insert-command
)
2937 (def-completion-wrapper electric-c-semi
:separator
)
2938 (define-key c-mode-map
"+" 'completion-separator-self-insert-command
)
2939 (define-key c-mode-map
"*" 'completion-separator-self-insert-command
)
2940 (define-key c-mode-map
"/" 'completion-separator-self-insert-command
)
2942 ;;; FORTRAN mode diffs. (these are defined when fortran is called)
2943 (defun completion-setup-fortran-mode ()
2944 (define-key fortran-mode-map
"+" 'completion-separator-self-insert-command
)
2945 (define-key fortran-mode-map
"-" 'completion-separator-self-insert-command
)
2946 (define-key fortran-mode-map
"*" 'completion-separator-self-insert-command
)
2947 (define-key fortran-mode-map
"/" 'completion-separator-self-insert-command
)
2950 ;;;-----------------------------------------------
2951 ;;; End of line chars.
2952 ;;;-----------------------------------------------
2953 (def-completion-wrapper newline
:separator
)
2954 (def-completion-wrapper newline-and-indent
:separator
)
2955 (if (function-defined-and-loaded 'shell-send-input
)
2956 (def-completion-wrapper shell-send-input
:separator
))
2957 (def-completion-wrapper exit-minibuffer
:minibuffer-separator
)
2958 (def-completion-wrapper eval-print-last-sexp
:separator
)
2959 (def-completion-wrapper eval-last-sexp
:separator
)
2960 ;;(def-completion-wrapper minibuffer-complete-and-exit :minibuffer)
2962 ;;;-----------------------------------------------
2964 ;;;-----------------------------------------------
2966 (def-completion-wrapper next-line
:under-or-before
)
2967 (def-completion-wrapper previous-line
:under-or-before
)
2968 (def-completion-wrapper beginning-of-buffer
:under-or-before
)
2969 (def-completion-wrapper end-of-buffer
:under-or-before
)
2971 ;; we patch these explicitly so they byte compile and so we don't have to
2972 ;; patch the faster underlying function.
2974 (defun cmpl-beginning-of-line (&optional n
)
2975 "Move point to beginning of current line.\n\
2976 With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
2977 If scan reaches end of buffer, stop there without error."
2979 (use-completion-under-or-before-point)
2980 (beginning-of-line n
)
2983 (defun cmpl-end-of-line (&optional n
)
2984 "Move point to end of current line.\n\
2985 With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
2986 If scan reaches end of buffer, stop there without error."
2988 (use-completion-under-or-before-point)
2992 (defun cmpl-forward-char (n)
2993 "Move point right ARG characters (left if ARG negative).\n\
2994 On reaching end of buffer, stop and signal error."
2996 (use-completion-under-or-before-point)
2999 (defun cmpl-backward-char (n)
3000 "Move point left ARG characters (right if ARG negative).\n\
3001 On attempt to pass beginning or end of buffer, stop and signal error."
3003 (use-completion-under-point)
3004 (if (eq last-command
'complete
)
3005 ;; probably a failed completion if you have to back up
3006 (cmpl-statistics-block (record-complete-failed)))
3010 (defun cmpl-forward-word (n)
3011 "Move point forward ARG words (backward if ARG is negative).\n\
3012 Normally returns t.\n\
3013 If an edge of the buffer is reached, point is left there\n\
3014 and nil is returned."
3016 (use-completion-under-or-before-point)
3019 (defun cmpl-backward-word (n)
3020 "Move backward until encountering the end of a word.
3021 With argument, do this that many times.
3022 In programs, it is faster to call forward-word with negative arg."
3024 (use-completion-under-point)
3025 (if (eq last-command
'complete
)
3026 ;; probably a failed completion if you have to back up
3027 (cmpl-statistics-block (record-complete-failed)))
3028 (forward-word (- n
))
3031 (defun cmpl-forward-sexp (n)
3032 "Move forward across one balanced expression.
3033 With argument, do this that many times."
3035 (use-completion-under-or-before-point)
3038 (defun cmpl-backward-sexp (n)
3039 "Move backward across one balanced expression.
3040 With argument, do this that many times."
3042 (use-completion-under-point)
3043 (if (eq last-command
'complete
)
3044 ;; probably a failed completion if you have to back up
3045 (cmpl-statistics-block (record-complete-failed)))
3049 (defun cmpl-delete-backward-char (n killflag
)
3050 "Delete the previous ARG characters (following, with negative ARG).\n\
3051 Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).\n\
3052 Interactively, ARG is the prefix arg, and KILLFLAG is set if\n\
3053 ARG was explicitly specified."
3054 (interactive "p\nP")
3055 (if (eq last-command
'complete
)
3056 ;; probably a failed completion if you have to back up
3057 (cmpl-statistics-block (record-complete-failed)))
3058 (delete-backward-char n killflag
)
3061 (defvar $$$cmpl-old-backward-delete-char-untabify
3062 (symbol-function 'backward-delete-char-untabify
))
3064 (defun backward-delete-char-untabify (arg &optional killp
)
3065 "Delete characters backward, changing tabs into spaces.
3066 Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
3067 Interactively, ARG is the prefix arg (default 1)
3068 and KILLP is t if prefix arg is was specified."
3069 (interactive "*p\nP")
3070 (if (eq last-command
'complete
)
3071 ;; probably a failed completion if you have to back up
3072 (cmpl-statistics-block (record-complete-failed)))
3073 (funcall $$$cmpl-old-backward-delete-char-untabify arg killp
)
3077 (global-set-key "\C-?" 'cmpl-delete-backward-char
)
3078 (global-set-key "\M-\C-F" 'cmpl-forward-sexp
)
3079 (global-set-key "\M-\C-B" 'cmpl-backward-sexp
)
3080 (global-set-key "\M-F" 'cmpl-forward-word
)
3081 (global-set-key "\M-B" 'cmpl-backward-word
)
3082 (global-set-key "\C-F" 'cmpl-forward-char
)
3083 (global-set-key "\C-B" 'cmpl-backward-char
)
3084 (global-set-key "\C-A" 'cmpl-beginning-of-line
)
3085 (global-set-key "\C-E" 'cmpl-end-of-line
)
3087 ;;;-----------------------------------------------
3089 ;;;-----------------------------------------------
3091 (def-completion-wrapper electric-buffer-list
:under-or-before
)
3092 (def-completion-wrapper list-buffers
:under-or-before
)
3093 (def-completion-wrapper scroll-up
:under-or-before
)
3094 (def-completion-wrapper scroll-down
:under-or-before
)
3095 (def-completion-wrapper execute-extended-command
3097 (def-completion-wrapper other-window
:under-or-before
)
3099 ;;;-----------------------------------------------
3100 ;;; Local Thinking Machines stuff
3101 ;;;-----------------------------------------------
3103 (if (fboundp 'up-ten-lines
)
3104 (def-completion-wrapper up-ten-lines
:under-or-before
))
3105 (if (fboundp 'down-ten-lines
)
3106 (def-completion-wrapper down-ten-lines
:under-or-before
))
3107 (if (fboundp 'tmc-scroll-up
)
3108 (def-completion-wrapper tmc-scroll-up
:under-or-before
))
3109 (if (fboundp 'tmc-scroll-down
)
3110 (def-completion-wrapper tmc-scroll-down
:under-or-before
))
3111 (if (fboundp 'execute-extended-command-and-check-for-bindings
)
3112 (def-completion-wrapper execute-extended-command-and-check-for-bindings
3121 (cmpl-statistics-block
3122 (record-completion-file-loaded))
3124 ;;; completion.el ends here