Mercurial > hg > xemacs-beta

comparison lisp/ilisp/ilisp-cmp.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children b82b59fe008d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; -*- Mode: Emacs-Lisp -*-
2
3 ;;; ilisp-cmp.el --
4
5 ;;; This file is part of ILISP.
6 ;;; Version: 5.7
7 ;;;
8 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
9 ;;; 1993, 1994 Ivan Vasquez
10 ;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker
11 ;;;
12 ;;; Other authors' names for which this Copyright notice also holds
13 ;;; may appear later in this file.
14 ;;;
15 ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
16 ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
17 ;;; mailing list were bugs and improvements are discussed.
18 ;;;
19 ;;; ILISP is freely redistributable under the terms found in the file
20 ;;; COPYING.
21
22
23
24 ;;;
25 ;;; ILISP completion
26 ;;;
27 ;;;
28 ;;;%Completion
29 ;;; The basic idea behind the completion stuff is to use as much of
30 ;;; the standard Emacs stuff as possible. The extensions here go out
31 ;;; to the inferior LISP to complete symbols if necessary.
32 ;;;
33 (defun ilisp-display-choices (symbol choices)
34 "Display the possible choices for SYMBOL in alist CHOICES."
35 (with-output-to-temp-buffer "*Completions*"
36 (display-completion-list
37 (sort
38 (all-completions (lisp-symbol-name symbol) choices)
39 'string-lessp))))
40
41 ;;;%%ilisp-can-complete
42 (defun ilisp-can-complete (symbol function-p)
43 "Return T if ilisp completion can complete SYMBOL from the current table."
44 (and ilisp-original
45 (string= (lisp-symbol-package ilisp-original)
46 (lisp-symbol-package symbol))
47 (string= (lisp-symbol-delimiter ilisp-original)
48 (lisp-symbol-delimiter symbol))
49 (lisp-prefix-p (lisp-symbol-name ilisp-original)
50 (lisp-symbol-name symbol))
51 (eq function-p ilisp-original-function-p)))
52
53 ;;;%%ilisp-complete
54 (defun ilisp-complete (symbol &optional function-p)
55 "Return a list of the possible completions for symbol from the
56 inferior LISP. If FUNCTION-P is T, only symbols with function
57 bindings will be considered. If no package is specified the buffer
58 package will be used."
59 (let* ((choices
60 (ilisp-send
61 (format (ilisp-value 'ilisp-complete-command)
62 (lisp-symbol-name symbol) (lisp-symbol-package symbol)
63 function-p
64 (string= (lisp-symbol-delimiter symbol) ":")
65 ilisp-prefix-match)
66 (if (not ilisp-complete)
67 (concat "Complete "
68 (if function-p "function ")
69 (lisp-buffer-symbol symbol)))
70 'complete)))
71 (if (ilisp-value 'comint-errorp t)
72 (progn (lisp-display-output choices)
73 (error "Error completing %s" (lisp-buffer-symbol symbol)))
74 (setq choices (read choices)
75 choices (if (eq choices 'NIL) nil choices)))
76 (setq ilisp-original symbol
77 ilisp-original-function-p function-p
78 ilisp-original-table choices)))
79
80 ;;;%%ilisp-completion-table
81 (defun ilisp-completion-table (symbol function-p)
82 "Return the completion table for SYMBOL trying to use the current
83 one. If FUNCTION-P is T, only symbols with function cells will be
84 returned."
85 (if (ilisp-can-complete symbol function-p)
86 ilisp-original-table
87 (ilisp-complete symbol function-p)))
88
89 ;;;%%Minibuffer completion
90 (defun ilisp-restore-prefix ()
91 "Restore the prefix from ilisp-mini-prefix at the start of the
92 minibuffer."
93 (if ilisp-mini-prefix
94 (save-excursion
95 (goto-char (point-min))
96 (insert ilisp-mini-prefix)
97 (setq ilisp-mini-prefix nil))))
98
99 ;;;
100 (defun ilisp-current-choice ()
101 "Set up the minibuffer completion table for the current symbol.
102 If there is a paren at the start of the minibuffer, or there is not an
103 ilisp-table, this will be from the inferior LISP. Otherwise, it will
104 be the ilisp-table."
105 (if (or (null ilisp-table) (eq (char-after 1) ?\())
106 (progn
107 (let* ((symbol-info (lisp-previous-symbol))
108 (symbol (car symbol-info)))
109 (setq minibuffer-completion-table
110 (ilisp-completion-table symbol ilisp-completion-function-p)))
111 (save-excursion
112 (skip-chars-backward "^: \(")
113 (setq ilisp-mini-prefix (buffer-substring (point-min) (point)))
114 (delete-region (point-min) (point)))
115 ;; Nothing can match this table
116 (if (not minibuffer-completion-table)
117 (setq minibuffer-completion-table '((" ")))))
118 (setq minibuffer-completion-table ilisp-table
119 minibuffer-completion-predicate nil)))
120
121 ;;;%%Commands
122 (defvar ilisp-completion-help
123 (lookup-key minibuffer-local-must-match-map "?"))
124 (defun ilisp-completion-help ()
125 "Inferior LISP minibuffer completion help."
126 (interactive)
127 (ilisp-current-choice)
128 (funcall ilisp-completion-help)
129 (ilisp-restore-prefix))
130
131 ;;;
132 (defvar ilisp-completion
133 (lookup-key minibuffer-local-must-match-map "\t"))
134 (defun ilisp-completion ()
135 "Inferior LISP minibuffer complete."
136 (interactive)
137 (ilisp-current-choice)
138 (funcall ilisp-completion)
139 (ilisp-restore-prefix))
140
141 ;;;
142 (defvar ilisp-completion-word
143 (lookup-key minibuffer-local-must-match-map " "))
144 (defun ilisp-completion-word ()
145 "Inferior LISP minibuffer complete word."
146 (interactive)
147 (if (eq (char-after 1) ?\()
148 (insert " ")
149 (ilisp-current-choice)
150 (funcall ilisp-completion-word)
151 (ilisp-restore-prefix)))
152
153 ;;;
154 (defun ilisp-completion-paren ()
155 "Only allow a paren if ilisp-paren is T."
156 (interactive)
157 (if ilisp-paren
158 (if (or (eq last-input-char ?\() (eq (char-after 1) ?\())
159 (insert last-input-char)
160 (beep))
161 (beep)))
162
163 ;;;
164 (defvar ilisp-completion-exit
165 (lookup-key minibuffer-local-must-match-map "\n"))
166 (defun ilisp-completion-exit ()
167 "Inferior LISP completion complete and exit."
168 (interactive)
169 (if (eq (char-after 1) ?\()
170 (progn (find-unbalanced-lisp nil)
171 (exit-minibuffer))
172 (if ilisp-no-complete
173 (exit-minibuffer)
174 (if (= (point-min) (point-max))
175 (exit-minibuffer)
176 (ilisp-current-choice)
177 (unwind-protect (funcall ilisp-completion-exit)
178 (ilisp-restore-prefix))))))
179
180 ;;;%%ilisp-completer
181 (defun ilisp-completer (symbol function-p)
182 "Complete SYMBOL from the inferior LISP using only function symbols
183 if FUNCTION-P is T. Return (SYMBOL LCS-SYMBOL CHOICES UNIQUEP)."
184 (let* ((name (lisp-symbol-name symbol))
185 (table (ilisp-completion-table symbol function-p))
186 (choice (and table (try-completion name table))))
187 (cond ((eq choice t) ;Name is it
188 (list symbol symbol nil t))
189 ((string= name choice) ;Name is LCS
190 (list symbol symbol (all-completions name table) nil))
191 (choice ;New LCS
192 (let ((symbol
193 (lisp-symbol (lisp-symbol-package symbol)
194 (lisp-symbol-delimiter symbol)
195 choice)))
196 (list symbol symbol (all-completions choice table) nil)))
197 ((and (not ilisp-prefix-match) table) ;Try partial matches
198 (let ((matches
199 (completer name table nil (regexp-quote completer-words))))
200 (cons (lisp-symbol (lisp-symbol-package symbol)
201 (lisp-symbol-delimiter symbol)
202 (car matches))
203 (cons (lisp-symbol (lisp-symbol-package symbol)
204 (lisp-symbol-delimiter symbol)
205 (car (cdr matches)))
206 (cdr (cdr matches)))))))))
207
208
209 ;;;%%ilisp-read
210 (defun ilisp-completion-map ()
211 "Set up the ilisp-completion-map from lisp-mode-map for the ilisp
212 readers and return it."
213 (if (not ilisp-completion-map)
214 (progn
215 (if (fboundp 'set-keymap-parent)
216 (progn
217 (setq ilisp-completion-map (make-sparse-keymap))
218 (set-keymap-parent ilisp-completion-map lisp-mode-map))
219 (setq ilisp-completion-map (copy-keymap lisp-mode-map)))
220 (define-key ilisp-completion-map " " 'ilisp-completion-word)
221 (define-key ilisp-completion-map "\t" 'ilisp-completion)
222 (define-key ilisp-completion-map "?" 'ilisp-completion-help)
223 (define-key ilisp-completion-map "\M-\t" 'ilisp-completion)
224 (define-key ilisp-completion-map "\n" 'ilisp-completion-exit)
225 (define-key ilisp-completion-map "\r" 'ilisp-completion-exit)
226 (define-key ilisp-completion-map "\C-g" 'abort-recursive-edit)
227 (define-key ilisp-completion-map "(" 'ilisp-completion-paren)
228 (define-key ilisp-completion-map ")" 'ilisp-completion-paren)
229 (define-key ilisp-completion-map "'" nil)
230 (define-key ilisp-completion-map "#" nil)
231 (define-key ilisp-completion-map "\"" nil)))
232 ilisp-completion-map)
233
234 ;;;
235 (defun ilisp-read (prompt &optional initial-contents)
236 "PROMPT in the minibuffer with optional INITIAL-CONTENTS and return
237 the result. Completion of symbols though the inferior LISP is
238 allowed."
239 (let ((ilisp-complete t)
240 (ilisp-paren t)
241 (ilisp-no-complete t)
242 (ilisp-completion-package (lisp-buffer-package)))
243 (read-from-minibuffer prompt initial-contents
244 (ilisp-completion-map))))
245
246 ;;;%%lisp-read-program
247 (defvar lisp-program-map nil
248 "Minibuffer map for reading a program and arguments.")
249
250 ;;;
251 (defun lisp-read-program (prompt &optional initial)
252 "Read a program with PROMPT and INITIAL. TAB or Esc-TAB will complete
253 filenames."
254 (if (null lisp-program-map)
255 (progn
256 (if (fboundp 'set-keymap-parent)
257 (progn
258 (setq lisp-program-map (make-sparse-keymap))
259 (set-keymap-parent lisp-program-map minibuffer-local-map))
260 (setq lisp-program-map (copy-keymap minibuffer-local-map)))
261 (define-key lisp-program-map "\M-\t" 'comint-dynamic-complete)
262 (define-key lisp-program-map "\t" 'comint-dynamic-complete)
263 (define-key lisp-program-map "?" 'comint-dynamic-list-completions)))
264 (read-from-minibuffer prompt initial lisp-program-map))
265
266 ;;;%%ilisp-read-symbol
267 (defun ilisp-read-symbol (prompt &optional default function-p no-complete)
268 "PROMPT in the minibuffer with optional DEFAULT and return a symbol
269 from the inferior LISP. If FUNCTION-P is T, only symbols with
270 function values will be returned. If NO-COMPLETE is T, then
271 uncompleted symbols will be allowed."
272 (let* ((ilisp-complete t)
273 (ilisp-no-complete no-complete)
274 (ilisp-completion-package (lisp-buffer-package))
275 (ilisp-completion-function-p function-p)
276 (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
277 (if (equal string "")
278 default
279 (lisp-string-to-symbol string))))
280
281 ;;;%%ilisp-completing-read
282 (defun ilisp-completing-read (prompt table &optional default)
283 "Read with PROMPT from an alist of TABLE. No input returns DEFAULT.
284 Symbols are from table, other specs are in parentheses."
285 (let* ((ilisp-complete t)
286 (ilisp-table table)
287 (ilisp-completion-package (lisp-buffer-package))
288 (ilisp-paren
289 (let ((entry table) (done nil))
290 (while (and entry (not done))
291 (setq done (= (elt (car (car entry)) 0) ?\()
292 entry (cdr entry)))
293 done))
294 (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
295 (if (string= string "") default string)))
296
297
298
299 ;;;%%complete-lisp
300 (autoload 'complete "completion" "Complete previous symbol." t)
301 (defun complete-lisp (mode)
302 "Complete the current symbol using information from the current
303 ILISP buffer. If in a string, complete as a filename. If called with
304 a positive prefix force all symbols to be considered. If called with
305 a negative prefix, undo the last completion. Partial completion is
306 allowed unless ilisp-prefix-match is T. If a symbol starts after a
307 left paren or #', then only function symbols will be considered.
308 Package specifications are also allowed and the distinction between
309 internal and exported symbols is considered."
310 (interactive "P")
311 (if (< (prefix-numeric-value mode) 0)
312 (completer-undo)
313 (let* ((filep
314 (save-excursion
315 (skip-chars-backward "^ \t\n")
316 (= (char-after (point)) ?\"))))
317 (if filep
318 (comint-dynamic-complete)
319 (let* ((symbol-info (lisp-previous-symbol))
320 (symbol (car symbol-info))
321 (name (lisp-symbol-name symbol))
322 (choice (ilisp-completer
323 symbol
324 (if (not mode) (car (cdr symbol-info)))))
325 (match (lisp-buffer-symbol (car choice)))
326 (lcs (lisp-buffer-symbol (car (cdr choice))))
327 (choices (car (cdr (cdr choice))))
328 (unique (car (cdr (cdr (cdr choice))))))
329 (skip-chars-backward " \t\n")
330 (completer-goto match lcs choices unique
331 (ilisp-value 'ilisp-symbol-delimiters)
332 completer-words)))
333 (message "Completed"))))
334