/[cmucl]/src/hemlock/echocoms.lisp
ViewVC logotype

Contents of /src/hemlock/echocoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Mar 13 15:49:52 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.7: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/echocoms.lisp,v 1.8 2001/03/13 15:49:52 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Echo area commands.
13 ;;;
14 ;;; Written by Rob MacLachlan and Skef Wholey.
15 ;;;
16 (in-package "HEMLOCK")
17
18 (defhvar "Beep on Ambiguity"
19 "If non-NIL, beep when completion of a parse is ambiguous."
20 :value t)
21
22 (defhvar "Ignore File Types"
23 "File types to ignore when trying to complete a filename."
24 :value
25 (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
26 "x86f" "lbytef" "core" "trace" ; Lisp
27 "BAK" "CKP" ; Backups & Checkpoints
28 "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting
29 "bbl" "lof" "idx" "lot" "aux" ; Formatting
30 "mo" "elc" ; Other editors
31 "bin" "lbin" ; Obvious binary extensions.
32 "o" "a" "aout" "out" ; UNIXY stuff
33 "bm" "onx" "snf" ; X stuff
34 "UU" "uu" "arc" "Z" "gz" "tar" ; Binary encoded files
35 ))
36
37
38 ;;; Field separator characters separate fields for TOPS-20 ^F style
39 ;;; completion.
40 (defattribute "Parse Field Separator"
41 "A value of 1 for this attribute indicates that the corresponding character
42 should be considered to be a field separator by the prompting commands.")
43 (setf (character-attribute :parse-field-separator #\space) 1)
44
45
46 ;;; Find-All-Completions -- Internal
47 ;;;
48 ;;; Return as a list of all the possible completions of String in the
49 ;;; list of string-tables Tables.
50 ;;;
51 (defun find-all-completions (string tables)
52 (do ((table tables (cdr table))
53 (res ()
54 (merge 'list (find-ambiguous string (car table))
55 res #'string-lessp)))
56 ((null table) res)))
57
58 (defcommand "Help on Parse" (p)
59 "Display help for parse in progress.
60 If there are a limited number of options then display them."
61 "Display the *Parse-Help* and any possibly completions of the current
62 input."
63 (declare (ignore p))
64 (let ((help (typecase *parse-help*
65 (list (unless *parse-help* (error "There is no parse help."))
66 (apply #'format nil *parse-help*))
67 (string *parse-help*)
68 (t (error "Parse help is not a string or list: ~S" *parse-help*))))
69 (input (region-to-string *parse-input-region*)))
70 (cond
71 ((eq *parse-type* :keyword)
72 (let ((strings (find-all-completions input *parse-string-tables*)))
73 (with-pop-up-display (s :height (+ (length strings) 2))
74 (write-line help s)
75 (cond (strings
76 (write-line "Possible completions of what you have typed:" s)
77 (dolist (string strings)
78 (write-line string s)))
79 (t
80 (write-line
81 "There are no possible completions of what you have typed." s))))))
82 ((and (eq *parse-type* :file) (not (zerop (length input))))
83 (let ((pns (ambiguous-files (region-to-string *parse-input-region*)
84 *parse-default*)))
85 (declare (list pns))
86 (with-pop-up-display(s :height (+ (length pns) 2))
87 (write-line help s)
88 (cond (pns
89 (write-line "Possible completions of what you have typed:" s)
90 (let ((width (- (window-width (current-window)) 27)))
91 (dolist (pn pns)
92 (let* ((dir (directory-namestring pn))
93 (len (length dir)))
94 (unless (<= len width)
95 (let ((slash (position #\/ dir
96 :start (+ (- len width) 3))))
97 (setf dir
98 (if slash
99 (concatenate 'string "..."
100 (subseq dir slash))
101 "..."))))
102 (format s " ~A~25T ~A~%"
103 (file-namestring pn) dir)))))
104 (t
105 (write-line
106 "There are no possible completions of what you have typed." s))))))
107 (t
108 (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting))
109 (insert-string m help)
110 (insert-character m #\newline))))))
111
112 (defun file-completion-action (typein)
113 (declare (simple-string typein))
114 (when (zerop (length typein)) (editor-error))
115 (multiple-value-bind
116 (result win)
117 (complete-file typein
118 :defaults (directory-namestring *parse-default*)
119 :ignore-types (value ignore-file-types))
120 (when result
121 (delete-region *parse-input-region*)
122 (insert-string (region-start *parse-input-region*)
123 (namestring result)))
124 (when (and (not win) (value beep-on-ambiguity))
125 (editor-error))))
126
127 (defcommand "Complete Keyword" (p)
128 "Trys to complete the text being read in the echo area as a string in
129 *parse-string-tables*"
130 "Complete the keyword being parsed as far as possible.
131 If it is ambiguous and ``Beep On Ambiguity'' true beep."
132 (declare (ignore p))
133 (let ((typein (region-to-string *parse-input-region*)))
134 (declare (simple-string typein))
135 (case *parse-type*
136 (:keyword
137 (multiple-value-bind
138 (prefix key value field ambig)
139 (complete-string typein *parse-string-tables*)
140 (declare (ignore value field))
141 (when prefix
142 (delete-region *parse-input-region*)
143 (insert-string (region-start *parse-input-region*) prefix)
144 (when (eq key :ambiguous)
145 (let ((point (current-point)))
146 (move-mark point (region-start *parse-input-region*))
147 (unless (character-offset point ambig)
148 (buffer-end point)))))
149 (when (and (or (eq key :ambiguous) (eq key :none))
150 (value beep-on-ambiguity))
151 (editor-error))))
152 (:file
153 (file-completion-action typein))
154 (t
155 (editor-error "Cannot complete input for this prompt.")))))
156
157 (defun field-separator-p (x)
158 (plusp (character-attribute :parse-field-separator x)))
159
160 (defcommand "Complete Field" (p)
161 "Complete a field in a parse.
162 Fields are defined by the :field separator attribute,
163 the text being read in the echo area as a string in *parse-string-tables*"
164 "Complete a field in a keyword.
165 If it is ambiguous and ``Beep On Ambiguity'' true beep. Fields are
166 separated by characters having a non-zero :parse-field-separator attribute,
167 and this command should only be bound to characters having that attribute."
168 (let ((typein (region-to-string *parse-input-region*)))
169 (declare (simple-string typein))
170 (case *parse-type*
171 (:string
172 (self-insert-command p))
173 (:file
174 (file-completion-action typein))
175 (:keyword
176 (let ((point (current-point)))
177 (unless (blank-after-p point)
178 (insert-character point
179 (ext:key-event-char *last-key-event-typed*))))
180 (multiple-value-bind
181 (prefix key value field ambig)
182 (complete-string typein *parse-string-tables*)
183 (declare (ignore value ambig))
184 (when (eq key :none) (editor-error "No possible completion."))
185 (delete-region *parse-input-region*)
186 (let ((new-typein (if (and (eq key :unique) (null field))
187 (subseq prefix 0 field)
188 (concatenate 'string
189 (subseq prefix 0 field)
190 (string
191 (ext:key-event-char
192 *last-key-event-typed*))))))
193 (insert-string (region-start *parse-input-region*) new-typein))))
194 (t
195 (editor-error "Cannot complete input for this prompt.")))))
196
197
198 (defvar *echo-area-history* (make-ring 10)
199 "This ring-buffer contains strings which were previously input in the
200 echo area.")
201
202 (defvar *echo-history-pointer* 0
203 "This is our current position to the ring during a historical exploration.")
204
205 (defcommand "Confirm Parse" (p)
206 "Terminate echo-area input.
207 If the input is invalid then an editor-error will signalled."
208 "If no input has been given, exits the recursive edit with the default,
209 otherwise calls the verification function."
210 (declare (ignore p))
211 (let* ((string (region-to-string *parse-input-region*))
212 (empty (zerop (length string))))
213 (declare (simple-string string))
214 (if empty
215 (when *parse-default* (setq string *parse-default*))
216 (when (or (zerop (ring-length *echo-area-history*))
217 (string/= string (ring-ref *echo-area-history* 0)))
218 (ring-push string *echo-area-history*)))
219 (multiple-value-bind (res flag)
220 (funcall *parse-verification-function* string)
221 (unless (or res flag) (editor-error))
222 (exit-recursive-edit res))))
223
224 (defcommand "Previous Parse" (p)
225 "Rotate the echo-area history forward.
226 If current input is non-empty and different from what is on the top
227 of the ring then push it on the ring before inserting the new input."
228 "Pop the *echo-area-history* ring buffer."
229 (let ((length (ring-length *echo-area-history*))
230 (p (or p 1)))
231 (when (zerop length) (editor-error))
232 (cond
233 ((eq (last-command-type) :echo-history)
234 (let ((base (mod (+ *echo-history-pointer* p) length)))
235 (delete-region *parse-input-region*)
236 (insert-string (region-end *parse-input-region*)
237 (ring-ref *echo-area-history* base))
238 (setq *echo-history-pointer* base)))
239 (t
240 (let ((current (region-to-string *parse-input-region*))
241 (base (mod (if (minusp p) p (1- p)) length)))
242 (delete-region *parse-input-region*)
243 (insert-string (region-end *parse-input-region*)
244 (ring-ref *echo-area-history* base))
245 (when (and (plusp (length current))
246 (string/= (ring-ref *echo-area-history* 0) current))
247 (ring-push current *echo-area-history*)
248 (incf base))
249 (setq *echo-history-pointer* base))))
250 (setf (last-command-type) :echo-history)))
251
252 (defcommand "Next Parse" (p)
253 "Rotate the echo-area history backward.
254 If current input is non-empty and different from what is on the top
255 of the ring then push it on the ring before inserting the new input."
256 "Push the *echo-area-history* ring buffer."
257 (previous-parse-command (- (or p 1))))
258
259 (defcommand "Illegal" (p)
260 "This signals an editor-error.
261 It is useful for making commands locally unbound."
262 "Just signals an editor-error."
263 (declare (ignore p))
264 (editor-error))
265
266 (add-hook window-buffer-hook
267 #'(lambda (window new-buff)
268 (when (and (eq window *echo-area-window*)
269 (not (eq new-buff *echo-area-buffer*)))
270 (editor-error "Can't change echo area window."))))
271
272 (defcommand "Beginning Of Parse" (p)
273 "Moves to immediately after the prompt when in the echo area."
274 "Move the point of the echo area buffer to *parse-starting-mark*."
275 (declare (ignore p))
276 (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*))
277
278 (defcommand "Echo Area Delete Previous Character" (p)
279 "Delete the previous character.
280 Don't let the luser rub out the prompt."
281 "Signal an editor-error if we would nuke the prompt,
282 otherwise do a normal delete."
283 (with-mark ((tem (buffer-point *echo-area-buffer*)))
284 (unless (character-offset tem (- (or p 1))) (editor-error))
285 (when (mark< tem *parse-starting-mark*) (editor-error))
286 (delete-previous-character-command p)))
287
288 (defcommand "Echo Area Kill Previous Word" (p)
289 "Kill the previous word.
290 Don't let the luser rub out the prompt."
291 "Signal an editor-error if we would mangle the prompt, otherwise
292 do a normal kill-previous-word."
293 (with-mark ((tem (buffer-point *echo-area-buffer*)))
294 (unless (word-offset tem (- (or p 1))) (editor-error))
295 (when (mark< tem *parse-starting-mark*) (editor-error))
296 (kill-previous-word-command p)))
297
298 (declaim (special *kill-ring*))
299
300 (defcommand "Kill Parse" (p)
301 "Kills any input so far."
302 "Kills *parse-input-region*."
303 (declare (ignore p))
304 (if (end-line-p (current-point))
305 (kill-region *parse-input-region* :kill-backward)
306 (ring-push (delete-and-save-region *parse-input-region*)
307 *kill-ring*)))
308
309 (defcommand "Insert Parse Default" (p)
310 "Inserts the default for the parse in progress.
311 The text is inserted at the point."
312 "Inserts *parse-default* at the point of the *echo-area-buffer*.
313 If there is no default an editor-error is signalled."
314 (declare (ignore p))
315 (unless *parse-default* (editor-error))
316 (insert-string (buffer-point *echo-area-buffer*) *parse-default*))
317
318 (defcommand "Echo Area Backward Character" (p)
319 "Go back one character.
320 Don't let the luser move into the prompt."
321 "Signal an editor-error if we try to go into the prompt, otherwise
322 do a backward-character command."
323 (backward-character-command p)
324 (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
325 (beginning-of-parse-command ())
326 (editor-error)))
327
328 (defcommand "Echo Area Backward Word" (p)
329 "Go back one word.
330 Don't let the luser move into the prompt."
331 "Signal an editor-error if we try to go into the prompt, otherwise
332 do a backward-word command."
333 (backward-word-command p)
334 (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
335 (beginning-of-parse-command ())
336 (editor-error)))

  ViewVC Help
Powered by ViewVC 1.1.5