1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 (declare (special completion-list cmp:worked cmp:mark cmp:last-completion
22 cmp:allow-ambiguous X Y minibufferp
23 previous-command current-command)
24 (*lexpr cmp:get-completion)
25 (*expr DCTL-position-cursor))
26
27 (%include e-macros)
28
29 (eval-when (eval compile)
30 (defun abort-completion macro (form)
31 '(prog2 (ring-tty-bell) (throw 0 nocomplete)))
32 (defun catch-abort macro (form)
33 `(catch ,@(cdr form) nocomplete)))
34
35 (or (boundp 'completion-list) (setq completion-list nil))
36 (setq cmp:worked nil cmp:mark nil cmp:last-completion nil)
37
38
39 (defcom complete-command
40 &numeric-argument (&pass)
41 (cond ((not minibufferp) (command-quit))
42 (numarg
43 (or (eq previous-command current-command)
44 (setq cmp:worked nil))
45 (cmp:display-completions))
46 ((cmp:undo-completion?)
47 (without-saving (wipe-point-mark cmp:mark))
48 (release-mark cmp:mark)
49 (catch-abort
50 (let ((completion-info
51 (cmp:get-completion (cmp:get-word)
52 cmp:last-completion)))
53 (cond (completion-info
54 (setq cmp:worked t
55 cmp:last-completion (car completion-info))
56 (insert-string
57 (substr (car completion-info)
58 (cdr completion-info)))
59 (insert-string SPACE))
60 (t (setq cmp:worked nil cmp:mark nil))))))
61 (t (catch-abort
62 (let ((completion-info (cmp:get-completion (cmp:get-word))))
63 (cond (completion-info
64 (setq cmp:worked t
65 cmp:last-completion (car completion-info))
66 (insert-string
67 (substr (car completion-info)
68 (cdr completion-info)))
69 (insert-char SPACE))))))))
70
71 (defun cmp:undo-completion? ()
72 (and cmp:worked
73 cmp:mark
74 (eq previous-command 'complete-command)))
75
76 (defun cmp:set-mark ()
77 (and cmp:mark (release-mark cmp:mark))
78 (setq cmp:mark (set-mark)))
79
80 (defun cmp:get-word ()
81 (cmp:set-mark)
82 (with-mark
83 here
84 (go-to-beginning-of-line)
85 (prog1 (point-mark-to-string here)
86 (go-to-mark here))))
87
88 (defun cmp:get-completion lexpr
89 (let ((word (arg 1))
90 (ignore-until (and (> lexpr 1) (arg 2)))
91 (found nil))
92 (do ((words (cond (ignore-until
93 (cdr (member ignore-until completion-list)))
94 (t completion-list))
95 (cdr words)))
96 ((null words)
97 (cond (found found)
98 (t (setq cmp:last-completion nil)
99 (abort-completion))))
100 (let ((cur-word (car words)))
101 (and (= (index cur-word word) 1)
102 (cond
103 (cmp:allow-ambiguous
104 (return (cons cur-word
105 (1+ (stringlength word)))))
106 (found (abort-completion))
107 (t (setq found
108 (cons cur-word
109 (1+ (stringlength word)))))))))))
110
111 (defun cmp:display-completions ()
112 (or completion-list
113 (display-error "There are no completions in effect."))
114 (let ((littleX X) (littleY Y))
115 (init-local-displays)
116 (local-display-generator-nnl "Current Completions in Effect")
117 (local-display-generator-nnl "")
118 (do ((words completion-list (cdr words)))
119 ((null words))
120 (local-display-generator-nnl (car words)))
121 (end-local-displays)
122 (DCTL-position-cursor littleX littleY)))