/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.124 - (show annotations)
Thu Feb 24 08:30:28 2005 UTC (9 years, 2 months ago) by rstrandh
Branch: MAIN
Changes since 1.123: +52 -15 lines
Many commands now capture their own error situations and give
reasonable error messages in the minibuffer.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;; GUI for the Climacs editor.
28
29 (in-package :climacs-gui)
30
31 (defclass extended-pane (climacs-pane)
32 (;; allows a certain number of commands to have some minimal memory
33 (previous-command :initform nil :accessor previous-command)
34 ;; for next-line and previous-line commands
35 (goal-column :initform nil)
36 ;; for dynamic abbrev expansion
37 (original-prefix :initform nil)
38 (prefix-start-offset :initform nil)
39 (dabbrev-expansion-mark :initform nil)
40 (overwrite-mode :initform nil)))
41
42 (defclass info-pane (application-pane)
43 ((climacs-pane :initarg :climacs-pane)))
44
45 (defclass minibuffer-pane (application-pane) ())
46
47 (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
48 (declare (ignore type args))
49 (window-clear pane))
50
51 (define-application-frame climacs ()
52 ((windows :accessor windows)
53 (buffers :initform '() :accessor buffers)
54 (recordingp :initform nil :accessor recordingp)
55 (executingp :initform nil :accessor executingp)
56 (recorded-keys :initform '() :accessor recorded-keys)
57 (remaining-keys :initform '() :accessor remaining-keys))
58 (:panes
59 (win (let* ((extended-pane
60 (make-pane 'extended-pane
61 :width 900 :height 400
62 :name 'bla
63 :end-of-line-action :scroll
64 :incremental-redisplay t
65 :display-function 'display-win))
66 (info-pane
67 (make-pane 'info-pane
68 :climacs-pane extended-pane
69 :width 900 :height 20 :max-height 20 :min-height 20
70 ::background +gray85+
71 :scroll-bars nil
72 :borders nil
73 :incremental-redisplay t
74 :display-function 'display-info)))
75 (vertically ()
76 (scrolling ()
77 extended-pane)
78 info-pane)))
79 (int (make-pane 'minibuffer-pane
80 :width 900 :height 20 :max-height 20 :min-height 20
81 :display-function 'display-minibuffer
82 :scroll-bars nil)))
83 (:layouts
84 (default
85 (vertically (:scroll-bars nil)
86 win
87 int)))
88 (:top-level (climacs-top-level)))
89
90 (defparameter *message* nil)
91
92 (defun display-message (format-string &rest format-args)
93 (setf *message*
94 (apply #'format nil format-string format-args)))
95
96 (defun display-minibuffer (frame pane)
97 (declare (ignore frame))
98 (unless (null *message*)
99 (princ *message* pane)
100 (setf *message* nil)))
101
102 (defmacro current-window () ; shouldn't this be an inlined function? --amb
103 `(car (windows *application-frame*)))
104
105 (defmethod execute-frame-command :around ((frame climacs) command)
106 (declare (ignore command))
107 (with-undo ((buffer (current-window)))
108 (call-next-method)))
109
110 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
111 (declare (ignore args))
112 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
113 (loop for buffer in buffers
114 do (update-syntax buffer (syntax buffer)))
115 (call-next-method)
116 (loop for buffer in buffers
117 do (clear-modify buffer))))
118
119 (defun climacs ()
120 "Starts up a climacs session"
121 (let ((frame (make-application-frame 'climacs)))
122 (run-frame-top-level frame)))
123
124 (defun display-info (frame pane)
125 (declare (ignore frame))
126 (with-slots (climacs-pane) pane
127 (let* ((buf (buffer climacs-pane))
128 (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a"
129 (if (needs-saving buf) "**" "--")
130 (name buf)
131 (name (syntax buf))
132 (if (slot-value climacs-pane 'overwrite-mode)
133 " Ovwrt"
134 "")
135 (if (auto-fill-mode climacs-pane)
136 " Fill"
137 "")
138 (if (isearch-mode climacs-pane)
139 " Isearch"
140 "")
141 (if (recordingp *application-frame*)
142 "Def"
143 ""))))
144 (princ name-info pane))))
145
146 (defun display-win (frame pane)
147 "The display function used by the climacs application frame."
148 (declare (ignore frame))
149 (redisplay-pane pane (eq pane (car (windows *application-frame*)))))
150
151 (defmethod handle-repaint :before ((pane extended-pane) region)
152 (declare (ignore region))
153 (redisplay-frame-panes *application-frame*))
154
155 (defun find-gestures (gestures start-table)
156 (loop with table = (find-command-table start-table)
157 for (gesture . rest) on gestures
158 for item = (find-keystroke-item gesture table :errorp nil)
159 while item
160 do (if (eq (command-menu-item-type item) :command)
161 (return (if (null rest) item nil))
162 (setf table (command-menu-item-value item)))
163 finally (return item)))
164
165 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
166 (defparameter *current-gesture* nil)
167
168 (defun meta-digit (gesture)
169 (position gesture
170 '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
171 (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
172 :test #'event-matches-gesture-name-p))
173
174 (defun climacs-read-gesture ()
175 (unless (null (remaining-keys *application-frame*))
176 (return-from climacs-read-gesture
177 (pop (remaining-keys *application-frame*))))
178 (loop for gesture = (read-gesture :stream *standard-input*)
179 until (or (characterp gesture)
180 (and (typep gesture 'keyboard-event)
181 (or (keyboard-event-character gesture)
182 (not (member (keyboard-event-key-name
183 gesture)
184 '(:control-left :control-right
185 :shift-left :shift-right
186 :meta-left :meta-right
187 :super-left :super-right
188 :hyper-left :hyper-right
189 :shift-lock :caps-lock
190 :alt-left :alt-right))))))
191 finally (progn (when (recordingp *application-frame*)
192 (push gesture (recorded-keys *application-frame*)))
193 (return gesture))))
194
195 (defun climacs-unread-gesture (gesture stream)
196 (cond ((recordingp *application-frame*)
197 (pop (recorded-keys *application-frame*))
198 (unread-gesture gesture :stream stream))
199 ((executingp *application-frame*)
200 (push gesture (remaining-keys *application-frame*)))
201 (t
202 (unread-gesture gesture :stream stream))))
203
204 (defun read-numeric-argument (&key (stream *standard-input*))
205 (let ((gesture (climacs-read-gesture)))
206 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
207 (let ((numarg 4))
208 (loop for gesture = (climacs-read-gesture)
209 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
210 do (setf numarg (* 4 numarg))
211 finally (climacs-unread-gesture gesture stream))
212 (let ((gesture (climacs-read-gesture)))
213 (cond ((and (characterp gesture)
214 (digit-char-p gesture 10))
215 (setf numarg (- (char-code gesture) (char-code #\0)))
216 (loop for gesture = (climacs-read-gesture)
217 while (and (characterp gesture)
218 (digit-char-p gesture 10))
219 do (setf numarg (+ (* 10 numarg)
220 (- (char-code gesture) (char-code #\0))))
221 finally (climacs-unread-gesture gesture stream)
222 (return (values numarg t))))
223 (t
224 (climacs-unread-gesture gesture stream)
225 (values numarg t))))))
226 ((meta-digit gesture)
227 (let ((numarg (meta-digit gesture)))
228 (loop for gesture = (climacs-read-gesture)
229 while (meta-digit gesture)
230 do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
231 finally (climacs-unread-gesture gesture stream)
232 (return (values numarg t)))))
233 (t (climacs-unread-gesture gesture stream)
234 (values 1 nil)))))
235
236 ;;; we know the vbox pane has a scroller pane and an info
237 ;;; pane in it. The scroller pane has a viewport in it,
238 ;;; and the viewport contains the climacs-pane as its only child.
239 (defun find-climacs-pane (vbox)
240 (first (sheet-children
241 (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
242 (sheet-children
243 (find-if (lambda (pane) (typep pane 'scroller-pane))
244 (sheet-children vbox)))))))
245
246 (defvar *numeric-argument-p* (list nil))
247
248 (defun substitute-numeric-argument-p (command numargp)
249 (substitute numargp *numeric-argument-p* command :test #'eq))
250
251 (defun climacs-top-level (frame &key
252 command-parser command-unparser
253 partial-command-parser prompt)
254 (declare (ignore command-parser command-unparser partial-command-parser prompt))
255 (with-slots (windows) frame
256 (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
257 (push (buffer (car windows)) (buffers frame))
258 (let ((*standard-output* (car windows))
259 (*standard-input* (find-pane-named frame 'int))
260 (*print-pretty* nil)
261 (*abort-gestures* '((:keyboard #\g 512))))
262 (redisplay-frame-panes frame :force-p t)
263 (flet ((do-command (command)
264 (handler-case
265 (execute-frame-command frame command)
266 (offset-before-beginning ()
267 (beep) (display-message "Beginning of buffer"))
268 (offset-after-end ()
269 (beep) (display-message "End of buffer"))
270 (motion-before-beginning ()
271 (beep) (display-message "Beginning of buffer"))
272 (motion-after-end ()
273 (beep) (display-message "End of buffer")))
274 (setf (previous-command *standard-output*)
275 (if (consp command)
276 (car command)
277 command)))
278 (update-climacs ()
279 (let ((buffer (buffer (current-window))))
280 (when (modified-p buffer)
281 (setf (needs-saving buffer) t)))
282 (when (null (remaining-keys *application-frame*))
283 (setf (executingp *application-frame*) nil)
284 (redisplay-frame-panes frame))))
285 (loop
286 for maybe-error = t
287 do (handler-case
288 (with-input-context ('(command
289 :command-table 'global-climacs-table))
290 (object)
291 (loop
292 for gestures = '()
293 do (multiple-value-bind (numarg numargp)
294 (read-numeric-argument :stream *standard-input*)
295 (loop (setf *current-gesture* (climacs-read-gesture))
296 (setf gestures (nconc gestures (list *current-gesture*)))
297 (let ((item (find-gestures gestures 'global-climacs-table)))
298 (cond ((not item)
299 (beep) (return))
300 ((eq (command-menu-item-type item) :command)
301 (let ((command (command-menu-item-value item)))
302 (unless (consp command)
303 (setf command (list command)))
304 (setf command (substitute-numeric-argument-marker command numarg))
305 (setf command (substitute-numeric-argument-p command numargp))
306 (do-command command)
307 (return)))
308 (t nil)))))
309 (update-climacs))
310 (t
311 (do-command object)
312 (setq maybe-error nil)))
313 (abort-gesture ()
314 (display-message "Quit")))
315 (when maybe-error
316 (beep))
317 (update-climacs))))))
318
319 (defmacro simple-command-loop (command-table loop-condition end-clauses)
320 (let ((gesture (gensym))
321 (item (gensym))
322 (command (gensym)))
323 `(progn
324 (redisplay-frame-panes *application-frame*)
325 (loop while ,loop-condition
326 as ,gesture = (climacs-read-gesture)
327 as ,item = (find-gestures (list ,gesture) ,command-table)
328 do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
329 (setf *current-gesture* ,gesture)
330 (let ((,command (command-menu-item-value ,item)))
331 (unless (consp ,command)
332 (setf ,command (list ,command)))
333 (handler-case
334 (execute-frame-command *application-frame*
335 ,command)
336 (offset-before-beginning ()
337 (beep) (display-message "Beginning of buffer"))
338 (offset-after-end ()
339 (beep) (display-message "End of buffer"))
340 (motion-before-beginning ()
341 (beep) (display-message "Beginning of buffer"))
342 (motion-after-end ()
343 (beep) (display-message "End of buffer")))))
344 (t
345 (unread-gesture ,gesture)
346 ,@end-clauses))
347 (redisplay-frame-panes *application-frame*)))))
348
349 (defun region-limits (pane)
350 (if (mark< (mark pane) (point pane))
351 (values (mark pane) (point pane))
352 (values (point pane) (mark pane))))
353
354 (defmacro define-named-command (command-name args &body body)
355 `(define-climacs-command ,(if (listp command-name)
356 `(,@command-name :name t)
357 `(,command-name :name t)) ,args ,@body))
358
359 (define-named-command com-toggle-overwrite-mode ()
360 (with-slots (overwrite-mode) (current-window)
361 (setf overwrite-mode (not overwrite-mode))))
362
363 (defun possibly-fill-line ()
364 (let* ((pane (current-window))
365 (buffer (buffer pane)))
366 (when (auto-fill-mode pane)
367 (let* ((fill-column (auto-fill-column pane))
368 (point (point pane))
369 (offset (offset point))
370 (tab-width (tab-space-count (stream-default-view pane)))
371 (syntax (syntax buffer)))
372 (when (>= (buffer-display-column buffer offset tab-width)
373 (1- fill-column))
374 (fill-line point
375 (lambda (mark)
376 (syntax-line-indentation mark tab-width syntax))
377 fill-column
378 tab-width))))))
379
380 (defun insert-character (char)
381 (let* ((win (current-window))
382 (point (point win)))
383 (unless (constituentp char)
384 (possibly-expand-abbrev point))
385 (when (whitespacep char)
386 (possibly-fill-line))
387 (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
388 (progn
389 (delete-range point)
390 (insert-object point char))
391 (insert-object point char))))
392
393 (define-command com-self-insert ()
394 (insert-character *current-gesture*))
395
396 (define-named-command com-beginning-of-line ()
397 (beginning-of-line (point (current-window))))
398
399 (define-named-command com-end-of-line ()
400 (end-of-line (point (current-window))))
401
402 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
403 (delete-range (point (current-window)) count))
404
405 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
406 (delete-range (point (current-window)) (- count)))
407
408 (define-named-command com-transpose-objects ()
409 (let* ((point (point (current-window))))
410 (unless (beginning-of-buffer-p point)
411 (when (end-of-line-p point)
412 (backward-object point))
413 (let ((object (object-after point)))
414 (delete-range point)
415 (backward-object point)
416 (insert-object point object)
417 (forward-object point)))))
418
419 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
420 (backward-object (point (current-window)) count))
421
422 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
423 (forward-object (point (current-window)) count))
424
425 (define-named-command com-transpose-words ()
426 (let* ((point (point (current-window))))
427 (let (bw1 bw2 ew1 ew2)
428 (backward-word point)
429 (setf bw1 (offset point))
430 (forward-word point)
431 (setf ew1 (offset point))
432 (forward-word point)
433 (when (= (offset point) ew1)
434 ;; this is emacs' message in the minibuffer
435 (error "Don't have two things to transpose"))
436 (setf ew2 (offset point))
437 (backward-word point)
438 (setf bw2 (offset point))
439 (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
440 (w1 (buffer-sequence (buffer point) bw1 ew1)))
441 (delete-word point)
442 (insert-sequence point w1)
443 (backward-word point)
444 (backward-word point)
445 (delete-word point)
446 (insert-sequence point w2)
447 (forward-word point)))))
448
449 (define-named-command com-transpose-lines ()
450 (let ((point (point (current-window))))
451 (beginning-of-line point)
452 (unless (beginning-of-buffer-p point)
453 (previous-line point))
454 (let* ((bol (offset point))
455 (eol (progn (end-of-line point)
456 (offset point)))
457 (line (buffer-sequence (buffer point) bol eol)))
458 (delete-region bol point)
459 ;; Remove newline at end of line as well.
460 (unless (end-of-buffer-p point)
461 (delete-range point))
462 ;; If the current line is at the end of the buffer, we want to
463 ;; be able to insert past it, so we need to get an extra line
464 ;; at the end.
465 (end-of-line point)
466 (when (end-of-buffer-p point)
467 (insert-object point #\Newline))
468 (next-line point 0)
469 (insert-sequence point line)
470 (insert-object point #\Newline))))
471
472 (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
473 (let* ((win (current-window))
474 (point (point win)))
475 (unless (or (eq (previous-command win) 'com-previous-line)
476 (eq (previous-command win) 'com-next-line))
477 (setf (slot-value win 'goal-column) (column-number point)))
478 (previous-line point (slot-value win 'goal-column) numarg)))
479
480 (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
481 (let* ((win (current-window))
482 (point (point win)))
483 (unless (or (eq (previous-command win) 'com-previous-line)
484 (eq (previous-command win) 'com-next-line))
485 (setf (slot-value win 'goal-column) (column-number point)))
486 (next-line point (slot-value win 'goal-column) numarg)))
487
488 (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
489 (open-line (point (current-window)) numarg))
490
491 (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
492 (numargp 'boolean :prompt "Kill entire lines?"))
493 (let* ((pane (current-window))
494 (point (point pane))
495 (mark (offset point)))
496 (cond ((or numargp (> numarg 1))
497 (loop repeat numarg
498 until (end-of-buffer-p point)
499 do (end-of-line point)
500 until (end-of-buffer-p point)
501 do (forward-object point)))
502 (t
503 (cond ((end-of-buffer-p point) nil)
504 ((end-of-line-p point)(forward-object point))
505 (t (end-of-line point)))))
506 (unless (mark= point mark)
507 (if (eq (previous-command pane) 'com-kill-line)
508 (kill-ring-concatenating-push *kill-ring*
509 (region-to-sequence mark point))
510 (kill-ring-standard-push *kill-ring*
511 (region-to-sequence mark point)))
512 (delete-region mark point))))
513
514 (define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
515 (forward-word (point (current-window)) count))
516
517 (define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
518 (backward-word (point (current-window)) count))
519
520 (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
521 (delete-word (point (current-window)) count))
522
523 (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words"))
524 (backward-delete-word (point (current-window)) count))
525
526 (define-named-command com-upcase-region ()
527 (let ((cw (current-window)))
528 (upcase-region (mark cw) (point cw))))
529
530 (define-named-command com-downcase-region ()
531 (let ((cw (current-window)))
532 (downcase-region (mark cw) (point cw))))
533
534 (define-named-command com-capitalize-region ()
535 (let ((cw (current-window)))
536 (capitalize-region (mark cw) (point cw))))
537
538 (define-named-command com-upcase-word ()
539 (upcase-word (point (current-window))))
540
541 (define-named-command com-downcase-word ()
542 (downcase-word (point (current-window))))
543
544 (define-named-command com-capitalize-word ()
545 (capitalize-word (point (current-window))))
546
547 (define-named-command com-tabify-region ()
548 (let ((pane (current-window)))
549 (multiple-value-bind (start end) (region-limits pane)
550 (tabify-region start end (tab-space-count (stream-default-view pane))))))
551
552 (define-named-command com-untabify-region ()
553 (let ((pane (current-window)))
554 (multiple-value-bind (start end) (region-limits pane)
555 (untabify-region start end (tab-space-count (stream-default-view pane))))))
556
557 (defun indent-current-line (pane point)
558 (let* ((buffer (buffer pane))
559 (view (stream-default-view pane))
560 (tab-space-count (tab-space-count view))
561 (indentation (syntax-line-indentation point
562 tab-space-count
563 (syntax buffer))))
564 (indent-line point indentation (and (indent-tabs-mode buffer)
565 tab-space-count))))
566
567 (define-named-command com-indent-line ()
568 (let* ((pane (current-window))
569 (point (point pane)))
570 (indent-current-line pane point)))
571
572 (define-named-command com-newline-and-indent ()
573 (let* ((pane (current-window))
574 (point (point pane)))
575 (insert-object point #\Newline)
576 (indent-current-line pane point)))
577
578 (define-named-command com-delete-indentation ()
579 (delete-indentation (point (current-window))))
580
581 (define-named-command com-auto-fill-mode ()
582 (let ((pane (current-window)))
583 (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
584
585 (define-named-command com-fill-paragraph ()
586 (let* ((pane (current-window))
587 (buffer (buffer pane))
588 (syntax (syntax buffer))
589 (point (point pane))
590 (begin-mark (clone-mark point))
591 (end-mark (clone-mark point)))
592 (unless (eql (object-before begin-mark) #\Newline)
593 (beginning-of-paragraph begin-mark syntax))
594 (unless (eql (object-after end-mark) #\Newline)
595 (end-of-paragraph end-mark syntax))
596 (do-buffer-region (object offset buffer
597 (offset begin-mark) (offset end-mark))
598 (when (eql object #\Newline)
599 (setf object #\Space)))
600 (let ((point-backup (clone-mark point)))
601 (setf (offset point) (offset end-mark))
602 (possibly-fill-line)
603 (setf (offset point) (offset point-backup)))))
604
605 (define-command com-extended-command ()
606 (let ((item (handler-case (accept 'command :prompt "Extended Command")
607 (error () (progn (beep)
608 (display-message "No such command")
609 (return-from com-extended-command nil))))))
610 (execute-frame-command *application-frame* item)))
611
612 (eval-when (:compile-toplevel :load-toplevel)
613 (define-presentation-type completable-pathname ()
614 :inherit-from 'pathname))
615
616 (defun filename-completer (so-far mode)
617 (flet ((remove-trail (s)
618 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
619 (if pos (1+ pos) 0)))))
620 (let* ((directory-prefix
621 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
622 ""
623 (namestring #+sbcl *default-pathname-defaults*
624 #+cmu (ext:default-directory)
625 #-(or sbcl cmu) *default-pathname-defaults*)))
626 (full-so-far (concatenate 'string directory-prefix so-far))
627 (pathnames
628 (loop with length = (length full-so-far)
629 for path in (directory (concatenate 'string
630 (remove-trail so-far)
631 "*.*"))
632 when (let ((mismatch (mismatch (namestring path) full-so-far)))
633 (or (null mismatch) (= mismatch length)))
634 collect path))
635 (strings (mapcar #'namestring pathnames))
636 (first-string (car strings))
637 (length-common-prefix nil)
638 (completed-string nil)
639 (full-completed-string nil))
640 (unless (null pathnames)
641 (setf length-common-prefix
642 (loop with length = (length first-string)
643 for string in (cdr strings)
644 do (setf length (min length (or (mismatch string first-string) length)))
645 finally (return length))))
646 (unless (null pathnames)
647 (setf completed-string
648 (subseq first-string (length directory-prefix)
649 (if (null (cdr pathnames)) nil length-common-prefix)))
650 (setf full-completed-string
651 (concatenate 'string directory-prefix completed-string)))
652 (case mode
653 ((:complete-limited :complete-maximal)
654 (cond ((null pathnames)
655 (values so-far nil nil 0 nil))
656 ((null (cdr pathnames))
657 (values completed-string t (car pathnames) 1 nil))
658 (t
659 (values completed-string nil nil (length pathnames) nil))))
660 (:complete
661 (cond ((null pathnames)
662 (values so-far t so-far 1 nil))
663 ((null (cdr pathnames))
664 (values completed-string t (car pathnames) 1 nil))
665 ((find full-completed-string strings :test #'string-equal)
666 (let ((pos (position full-completed-string strings :test #'string-equal)))
667 (values completed-string
668 t (elt pathnames pos) (length pathnames) nil)))
669 (t
670 (values completed-string nil nil (length pathnames) nil))))
671 (:possibilities
672 (values nil nil nil (length pathnames)
673 (loop with length = (length directory-prefix)
674 for name in pathnames
675 collect (list (subseq (namestring name) length nil)
676 name))))))))
677
678 (define-presentation-method accept
679 ((type completable-pathname) stream (view textual-view) &key)
680 (multiple-value-bind (pathname success string)
681 (complete-input stream
682 #'filename-completer
683 :partial-completers '(#\Space)
684 :allow-any-input t)
685 (declare (ignore success))
686 (or pathname string)))
687
688 (defun pathname-filename (pathname)
689 (if (null (pathname-type pathname))
690 (pathname-name pathname)
691 (concatenate 'string (pathname-name pathname)
692 "." (pathname-type pathname))))
693
694 (define-named-command com-find-file ()
695 (let ((filename (accept 'completable-pathname
696 :prompt "Find File"))
697 (buffer (make-instance 'climacs-buffer))
698 (pane (current-window)))
699 (push buffer (buffers *application-frame*))
700 (setf (buffer (current-window)) buffer)
701 (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
702 ;; Don't want to create the file if it doesn't exist.
703 (when (probe-file filename)
704 (with-open-file (stream filename :direction :input)
705 (input-from-stream stream buffer 0)))
706 (setf (filename buffer) filename
707 (name buffer) (pathname-filename filename)
708 (needs-saving buffer) nil)
709 (beginning-of-buffer (point pane))
710 ;; this one is needed so that the buffer modification protocol
711 ;; resets the low and high marks after redisplay
712 (redisplay-frame-panes *application-frame*)))
713
714 (defun save-buffer (buffer)
715 (let ((filename (or (filename buffer)
716 (accept 'completable-pathname
717 :prompt "Save Buffer to File"))))
718 (with-open-file (stream filename :direction :output :if-exists :supersede)
719 (output-to-stream stream buffer 0 (size buffer)))
720 (setf (filename buffer) filename
721 (name buffer) (pathname-filename filename))
722 (display-message "Wrote: ~a" (filename buffer))
723 (setf (needs-saving buffer) nil)))
724
725 (define-named-command com-save-buffer ()
726 (let ((buffer (buffer (current-window))))
727 (if (or (null (filename buffer))
728 (needs-saving buffer))
729 (save-buffer buffer)
730 (display-message "No changes need to be saved from ~a" (name buffer)))))
731
732 (define-named-command (com-quit) ()
733 (loop for buffer in (buffers *application-frame*)
734 when (and (needs-saving buffer)
735 (handler-case (accept 'boolean
736 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
737 (error () (progn (beep)
738 (display-message "Invalid answer")
739 (return-from com-quit nil)))))
740 do (save-buffer buffer))
741 (when (or (notany #'needs-saving
742 (buffers *application-frame*))
743 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
744 (error () (progn (beep)
745 (display-message "Invalid answer")
746 (return-from com-quit nil)))))
747 (frame-exit *application-frame*)))
748
749 (define-named-command com-write-buffer ()
750 (let ((filename (accept 'completable-pathname
751 :prompt "Write Buffer to File"))
752 (buffer (buffer (current-window))))
753 (with-open-file (stream filename :direction :output :if-exists :supersede)
754 (output-to-stream stream buffer 0 (size buffer)))
755 (setf (filename buffer) filename
756 (name buffer) (pathname-filename filename)
757 (needs-saving buffer) nil)
758 (display-message "Wrote: ~a" (filename buffer))))
759
760 (define-presentation-method accept
761 ((type buffer) stream (view textual-view) &key)
762 (multiple-value-bind (object success string)
763 (complete-input stream
764 (lambda (so-far action)
765 (complete-from-possibilities
766 so-far (buffers *application-frame*) '() :action action
767 :name-key #'name
768 :value-key #'identity))
769 :partial-completers '(#\Space)
770 :allow-any-input t)
771 (declare (ignore success))
772 (or object
773 (car (push (make-instance 'climacs-buffer :name string)
774 (buffers *application-frame*))))))
775
776 (define-named-command com-switch-to-buffer ()
777 (let ((buffer (accept 'buffer
778 :prompt "Switch to buffer")))
779 (setf (buffer (current-window)) buffer)
780 (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
781 (beginning-of-buffer (point (current-window)))
782 (full-redisplay (current-window))))
783
784 (define-named-command com-kill-buffer ()
785 (with-slots (buffers) *application-frame*
786 (let ((buffer (buffer (current-window))))
787 (when (and (needs-saving buffer)
788 (handler-case (accept 'boolean :prompt "Save buffer first?")
789 (error () (progn (beep)
790 (display-message "Invalid answer")
791 (return-from com-kill-buffer nil)))))
792 (com-save-buffer))
793 (setf buffers (remove buffer buffers))
794 ;; Always need one buffer.
795 (when (null buffers)
796 (push (make-instance 'climacs-buffer :name "*scratch*")
797 buffers))
798 (setf (buffer (current-window)) (car buffers)))))
799
800 (define-named-command com-full-redisplay ()
801 (full-redisplay (current-window)))
802
803 (define-named-command com-load-file ()
804 (let ((filename (accept 'completable-pathname
805 :prompt "Load File")))
806 (load filename)))
807
808 (define-named-command com-beginning-of-buffer ()
809 (beginning-of-buffer (point (current-window))))
810
811 (define-named-command com-page-down ()
812 (let ((pane (current-window)))
813 (page-down pane)))
814
815 (define-named-command com-page-up ()
816 (let ((pane (current-window)))
817 (page-up pane)))
818
819 (define-named-command com-end-of-buffer ()
820 (end-of-buffer (point (current-window))))
821
822 (define-named-command com-back-to-indentation ()
823 (let ((point (point (current-window))))
824 (beginning-of-line point)
825 (loop until (end-of-line-p point)
826 while (whitespacep (object-after point))
827 do (incf (offset point)))))
828
829 (define-named-command com-goto-position ()
830 (setf (offset (point (current-window)))
831 (handler-case (accept 'integer :prompt "Goto Position")
832 (error () (progn (beep)
833 (display-message "Not a valid position")
834 (return-from com-goto-position nil))))))
835
836 (define-named-command com-goto-line ()
837 (loop with mark = (make-instance 'standard-right-sticky-mark ;PB
838 :buffer (buffer (current-window)))
839 do (end-of-line mark)
840 until (end-of-buffer-p mark)
841 repeat (handler-case (accept 'integer :prompt "Goto Line")
842 (error () (progn (beep)
843 (display-message "Not a valid line number")
844 (return-from com-goto-line nil))))
845 do (incf (offset mark))
846 (end-of-line mark)
847 finally (beginning-of-line mark)
848 (setf (offset (point (current-window)))
849 (offset mark))))
850
851 (define-named-command com-browse-url ()
852 (accept 'url :prompt "Browse URL"))
853
854 (define-named-command com-set-mark ()
855 (let ((pane (current-window)))
856 (setf (mark pane) (clone-mark (point pane)))))
857
858 (define-named-command com-exchange-point-and-mark ()
859 (let ((pane (current-window)))
860 (psetf (offset (mark pane)) (offset (point pane))
861 (offset (point pane)) (offset (mark pane)))))
862
863 (define-named-command com-set-syntax ()
864 (let* ((pane (current-window))
865 (buffer (buffer pane)))
866 (setf (syntax buffer)
867 (make-instance (or (accept 'syntax :prompt "Set Syntax")
868 (progn (beep)
869 (display-message "No such syntax")
870 (return-from com-set-syntax nil)))
871 :buffer buffer))
872 (setf (offset (low-mark buffer)) 0
873 (offset (high-mark buffer)) (size buffer))))
874
875 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
876 ;;;
877 ;;; Keyboard macros
878
879 (define-named-command com-start-kbd-macro ()
880 (setf (recordingp *application-frame*) t)
881 (setf (recorded-keys *application-frame*) '()))
882
883 (define-named-command com-end-kbd-macro ()
884 (setf (recordingp *application-frame*) nil)
885 (setf (recorded-keys *application-frame*)
886 ;; this won't work if the command was invoked in any old way
887 (reverse (cddr (recorded-keys *application-frame*)))))
888
889 (define-named-command com-call-last-kbd-macro ()
890 (setf (remaining-keys *application-frame*)
891 (recorded-keys *application-frame*))
892 (setf (executingp *application-frame*) t))
893
894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
895 ;;;
896 ;;; Commands for splitting windows
897
898 (defun replace-constellation (constellation additional-constellation vertical-p)
899 (let* ((parent (sheet-parent constellation))
900 (children (sheet-children parent))
901 (first (first children))
902 (second (second children))
903 (third (third children))
904 (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
905 (assert (member constellation children))
906 (sheet-disown-child parent constellation)
907 (let ((new (if vertical-p
908 (vertically ()
909 constellation adjust additional-constellation)
910 (horizontally ()
911 constellation adjust additional-constellation))))
912 (sheet-adopt-child parent new)
913 (reorder-sheets parent
914 (if (eq constellation first)
915 (if third
916 (list new second third)
917 (list new second))
918 (if third
919 (list first second new)
920 (list first new)))))))
921
922 (defun parent3 (sheet)
923 (sheet-parent (sheet-parent (sheet-parent sheet))))
924
925 (defun make-pane-constellation ()
926 "make a vbox containing a scroller pane as its first child and an
927 info pane as its second child. The scroller pane contains a viewport
928 which contains an extended pane. Return the vbox and the extended pane
929 as two values"
930 (let* ((extended-pane
931 (make-pane 'extended-pane
932 :width 900 :height 400
933 :name 'win
934 :end-of-line-action :scroll
935 :incremental-redisplay t
936 :display-function 'display-win))
937 (vbox
938 (vertically ()
939 (scrolling () extended-pane)
940 (make-pane 'info-pane
941 :climacs-pane extended-pane
942 :width 900 :height 20
943 :max-height 20 :min-height 20
944 ::background +gray85+
945 :scroll-bars nil
946 :borders nil
947 :incremental-redisplay t
948 :display-function 'display-info))))
949 (values vbox extended-pane)))
950
951 (define-named-command com-split-window-vertically ()
952 (with-look-and-feel-realization
953 ((frame-manager *application-frame*) *application-frame*)
954 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
955 (let* ((current-window (current-window))
956 (constellation-root (parent3 current-window)))
957 (setf (buffer new-pane) (buffer current-window)
958 (auto-fill-mode new-pane) (auto-fill-mode current-window)
959 (auto-fill-column new-pane) (auto-fill-column current-window))
960 (push new-pane (windows *application-frame*))
961 (replace-constellation constellation-root vbox t)
962 (full-redisplay current-window)
963 (full-redisplay new-pane)))))
964
965 (define-named-command com-split-window-horizontally ()
966 (with-look-and-feel-realization
967 ((frame-manager *application-frame*) *application-frame*)
968 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
969 (let* ((current-window (current-window))
970 (constellation-root (parent3 current-window)))
971 (setf (buffer new-pane) (buffer current-window)
972 (auto-fill-mode new-pane) (auto-fill-mode current-window)
973 (auto-fill-column new-pane) (auto-fill-column current-window))
974 (push new-pane (windows *application-frame*))
975 (replace-constellation constellation-root vbox nil)
976 (full-redisplay current-window)
977 (full-redisplay new-pane)))))
978
979 (define-named-command com-other-window ()
980 (setf (windows *application-frame*)
981 (append (cdr (windows *application-frame*))
982 (list (car (windows *application-frame*))))))
983
984 (define-named-command com-single-window ()
985 (loop until (null (cdr (windows *application-frame*)))
986 do (rotatef (car (windows *application-frame*))
987 (cadr (windows *application-frame*)))
988 (com-delete-window)))
989
990 (define-named-command com-delete-window ()
991 (unless (null (cdr (windows *application-frame*)))
992 (let* ((constellation (parent3 (current-window)))
993 (box (sheet-parent constellation))
994 (box-children (sheet-children box))
995 (other (if (eq constellation (first box-children))
996 (third box-children)
997 (first box-children)))
998 (parent (sheet-parent box))
999 (children (sheet-children parent))
1000 (first (first children))
1001 (second (second children))
1002 (third (third children)))
1003 (pop (windows *application-frame*))
1004 (sheet-disown-child box other)
1005 (sheet-disown-child parent box)
1006 (sheet-adopt-child parent other)
1007 (reorder-sheets parent (if (eq box first)
1008 (if third
1009 (list other second third)
1010 (list other second))
1011 (if third
1012 (list first second other)
1013 (list first other)))))))
1014
1015 ;;;;;;;;;;;;;;;;;;;;
1016 ;; Kill ring commands
1017
1018 ;; Copies an element from a kill-ring to a buffer at the given offset
1019 (define-named-command com-yank ()
1020 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
1021
1022 ;; Destructively cut a given buffer region into the kill-ring
1023 (define-named-command com-cut-out ()
1024 (multiple-value-bind (start end) (region-limits (current-window))
1025 (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
1026 (delete-region (offset start) end)))
1027
1028 ;; Non destructively copies in buffer region to the kill ring
1029 (define-named-command com-copy-out ()
1030 (let ((pane (current-window)))
1031 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
1032
1033 (define-named-command com-rotate-yank ()
1034 (let* ((pane (current-window))
1035 (point (point pane))
1036 (last-yank (kill-ring-yank *kill-ring*)))
1037 (if (eq (previous-command pane)
1038 'com-rotate-yank)
1039 (progn
1040 (delete-range point (* -1 (length last-yank)))
1041 (rotate-yank-position *kill-ring*)))
1042 (insert-sequence point (kill-ring-yank *kill-ring*))))
1043
1044 (define-named-command com-resize-kill-ring ()
1045 (let ((size (handler-case (accept 'integer :prompt "New kill ring size")
1046 (error () (progn (beep)
1047 (display-message "Not a valid kill ring size")
1048 (return-from com-resize-kill-ring nil))))))
1049 (setf (kill-ring-max-size *kill-ring*) size)))
1050
1051 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1052 ;;;
1053 ;;; Incremental search
1054
1055 (defun isearch-command-loop (pane forwardp)
1056 (let ((point (point pane)))
1057 (unless (endp (isearch-states pane))
1058 (setf (isearch-previous-string pane)
1059 (search-string (first (isearch-states pane)))))
1060 (setf (isearch-mode pane) t)
1061 (setf (isearch-states pane)
1062 (list (make-instance 'isearch-state
1063 :search-string ""
1064 :search-mark (clone-mark point)
1065 :search-forward-p forwardp
1066 :search-success-p t)))
1067 (simple-command-loop 'isearch-climacs-table
1068 (isearch-mode pane)
1069 ((setf (isearch-mode pane) nil)))))
1070
1071 (defun isearch-from-mark (pane mark string forwardp)
1072 (flet ((object-equal (x y)
1073 (if (characterp x)
1074 (and (characterp y) (char-equal x y))
1075 (eql x y))))
1076 (let* ((point (point pane))
1077 (mark2 (clone-mark mark))
1078 (success (funcall (if forwardp #'search-forward #'search-backward)
1079 mark2
1080 string
1081 :test #'object-equal)))
1082 (when success
1083 (setf (offset point) (offset mark2)
1084 (offset mark) (if forwardp
1085 (- (offset mark2) (length string))
1086 (+ (offset mark2) (length string)))))
1087 (push (make-instance 'isearch-state
1088 :search-string string
1089 :search-mark mark
1090 :search-forward-p forwardp
1091 :search-success-p success)
1092 (isearch-states pane))
1093 (unless success
1094 (beep)))))
1095
1096 (define-named-command com-isearch-mode-forward ()
1097 (isearch-command-loop (current-window) t))
1098
1099 (define-named-command com-isearch-mode-backward ()
1100 (isearch-command-loop (current-window) nil))
1101
1102 (define-named-command com-isearch-append-char ()
1103 (let* ((pane (current-window))
1104 (states (isearch-states pane))
1105 (string (concatenate 'string
1106 (search-string (first states))
1107 (string *current-gesture*)))
1108 (mark (clone-mark (search-mark (first states))))
1109 (forwardp (search-forward-p (first states))))
1110 (unless forwardp
1111 (incf (offset mark)))
1112 (isearch-from-mark pane mark string forwardp)))
1113
1114 (define-named-command com-isearch-delete-char ()
1115 (let* ((pane (current-window)))
1116 (cond ((null (second (isearch-states pane)))
1117 (beep))
1118 (t
1119 (pop (isearch-states pane))
1120 (loop until (endp (rest (isearch-states pane)))
1121 until (search-success-p (first (isearch-states pane)))
1122 do (pop (isearch-states pane)))
1123 (let ((state (first (isearch-states pane))))
1124 (setf (offset (point pane))
1125 (if (search-forward-p state)
1126 (+ (offset (search-mark state))
1127 (length (search-string state)))
1128 (- (offset (search-mark state))
1129 (length (search-string state))))))))))
1130
1131 (define-named-command com-isearch-forward ()
1132 (let* ((pane (current-window))
1133 (point (point pane))
1134 (states (isearch-states pane))
1135 (string (if (null (second states))
1136 (isearch-previous-string pane)
1137 (search-string (first states))))
1138 (mark (clone-mark point)))
1139 (isearch-from-mark pane mark string t)))
1140
1141 (define-named-command com-isearch-backward ()
1142 (let* ((pane (current-window))
1143 (point (point pane))
1144 (states (isearch-states pane))
1145 (string (if (null (second states))
1146 (isearch-previous-string pane)
1147 (search-string (first states))))
1148 (mark (clone-mark point)))
1149 (isearch-from-mark pane mark string nil)))
1150
1151 (define-named-command com-isearch-exit ()
1152 (setf (isearch-mode (current-window)) nil))
1153
1154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1155 ;;;
1156 ;;; Query replace
1157
1158 (defun query-replace-find-next-match (mark string)
1159 (flet ((object-equal (x y)
1160 (and (characterp x)
1161 (characterp y)
1162 (char-equal x y))))
1163 (let ((offset-before (offset mark)))
1164 (search-forward mark string :test #'object-equal)
1165 (/= (offset mark) offset-before))))
1166
1167 (define-named-command com-query-replace ()
1168 (let* ((string1 (handler-case (accept 'string :prompt "Query replace")
1169 (error () (progn (beep)
1170 (display-message "Empty string")
1171 (return-from com-query-replace nil)))))
1172 (string2 (handler-case (accept 'string
1173 :prompt (format nil "Query replace ~A with"
1174 string1))
1175 (error () (progn (beep)
1176 (display-message "Empty string")
1177 (return-from com-query-replace nil)))))
1178 (pane (current-window))
1179 (point (point pane)))
1180 (when (query-replace-find-next-match point string1)
1181 (setf (query-replace-state pane) (make-instance 'query-replace-state
1182 :string1 string1
1183 :string2 string2)
1184 (query-replace-mode pane) t)
1185 (simple-command-loop 'query-replace-climacs-table
1186 (query-replace-mode pane)
1187 ((setf (query-replace-mode pane) nil))))))
1188
1189 (define-named-command com-query-replace-replace ()
1190 (let* ((pane (current-window))
1191 (point (point pane))
1192 (buffer (buffer pane))
1193 (state (query-replace-state pane))
1194 (string1-length (length (string1 state))))
1195 (backward-object point string1-length)
1196 (let* ((offset1 (offset point))
1197 (offset2 (+ offset1 string1-length))
1198 (region-case (buffer-region-case buffer offset1 offset2)))
1199 (delete-range point string1-length)
1200 (insert-sequence point (string2 state))
1201 (setf offset2 (+ offset1 (length (string2 state))))
1202 (finish-output *error-output*)
1203 (case region-case
1204 (:upper-case (upcase-buffer-region buffer offset1 offset2))
1205 (:lower-case (downcase-buffer-region buffer offset1 offset2))
1206 (:capitalized (capitalize-buffer-region buffer offset1 offset2))))
1207 (unless (query-replace-find-next-match point (string1 state))
1208 (setf (query-replace-mode pane) nil))))
1209
1210 (define-named-command com-query-replace-skip ()
1211 (let* ((pane (current-window))
1212 (point (point pane))
1213 (state (query-replace-state pane)))
1214 (unless (query-replace-find-next-match point (string1 state))
1215 (setf (query-replace-mode pane) nil))))
1216
1217 (define-named-command com-query-replace-exit ()
1218 (setf (query-replace-mode (current-window)) nil))
1219
1220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1221 ;;;
1222 ;;; Undo/redo
1223
1224 (define-named-command com-undo ()
1225 (undo (undo-tree (buffer (current-window)))))
1226
1227 (define-named-command com-redo ()
1228 (redo (undo-tree (buffer (current-window)))))
1229
1230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1231 ;;;
1232 ;;; Dynamic abbrevs
1233
1234 (define-named-command com-dabbrev-expand ()
1235 (let* ((win (current-window))
1236 (point (point win)))
1237 (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
1238 (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
1239 (setf (offset dabbrev-expansion-mark)
1240 (offset point))
1241 (forward-word dabbrev-expansion-mark))
1242 ((mark< dabbrev-expansion-mark point)
1243 (backward-object dabbrev-expansion-mark))
1244 (t (forward-object dabbrev-expansion-mark)))))
1245 (unless (or (beginning-of-buffer-p point)
1246 (not (constituentp (object-before point))))
1247 (unless (and (eq (previous-command win) 'com-dabbrev-expand)
1248 (not (null prefix-start-offset)))
1249 (setf dabbrev-expansion-mark (clone-mark point))
1250 (backward-word dabbrev-expansion-mark)
1251 (setf prefix-start-offset (offset dabbrev-expansion-mark))
1252 (setf original-prefix (region-to-sequence prefix-start-offset point))
1253 (move))
1254 (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
1255 (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
1256 (not (constituentp (object-before dabbrev-expansion-mark))))
1257 (looking-at dabbrev-expansion-mark original-prefix)))
1258 do (move))
1259 (if (end-of-buffer-p dabbrev-expansion-mark)
1260 (progn (delete-region prefix-start-offset point)
1261 (insert-sequence point original-prefix)
1262 (setf prefix-start-offset nil))
1263 (progn (delete-region prefix-start-offset point)
1264 (insert-sequence point
1265 (let ((offset (offset dabbrev-expansion-mark)))
1266 (prog2 (forward-word dabbrev-expansion-mark)
1267 (region-to-sequence offset dabbrev-expansion-mark)
1268 (setf (offset dabbrev-expansion-mark) offset))))
1269 (move))))))))
1270
1271 (define-named-command com-beginning-of-paragraph ()
1272 (let* ((pane (current-window))
1273 (point (point pane))
1274 (syntax (syntax (buffer pane))))
1275 (beginning-of-paragraph point syntax)))
1276
1277 (define-named-command com-end-of-paragraph ()
1278 (let* ((pane (current-window))
1279 (point (point pane))
1280 (syntax (syntax (buffer pane))))
1281 (end-of-paragraph point syntax)))
1282
1283 (define-named-command com-backward-to-error ()
1284 (let* ((pane (current-window))
1285 (point (point pane))
1286 (syntax (syntax (buffer pane))))
1287 (display-message "~a" (backward-to-error point syntax))))
1288
1289 (define-named-command com-forward-to-error ()
1290 (let* ((pane (current-window))
1291 (point (point pane))
1292 (syntax (syntax (buffer pane))))
1293 (display-message "~a" (forward-to-error point syntax))))
1294
1295 (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
1296 (let* ((*package* (find-package :climacs-gui))
1297 (string (handler-case (accept 'string :prompt "Eval")
1298 (error () (progn (beep)
1299 (display-message "Empty string")
1300 (return-from com-eval-expression nil)))))
1301 (result (format nil "~a"
1302 (handler-case (eval (read-from-string string))
1303 (error (condition) (progn (beep)
1304 (display-message "~a" condition)
1305 (return-from com-eval-expression nil)))))))
1306 (if insertp
1307 (insert-sequence (point (current-window)) result)
1308 (display-message result))))
1309
1310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1311 ;;;
1312 ;;; Global and dead-escape command tables
1313
1314 (make-command-table 'global-climacs-table :errorp nil)
1315
1316 (make-command-table 'dead-escape-climacs-table :errorp nil)
1317
1318 (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
1319 :menu 'dead-escape-climacs-table
1320 :keystroke '(:escape))
1321
1322 (defun dead-escape-set-key (gesture command)
1323 (add-command-to-command-table command 'dead-escape-climacs-table
1324 :keystroke gesture :errorp nil))
1325
1326 (defun global-set-key (gesture command)
1327 (add-command-to-command-table command 'global-climacs-table
1328 :keystroke gesture :errorp nil)
1329 (when (and
1330 (listp gesture)
1331 (find :meta gesture))
1332 (dead-escape-set-key (remove :meta gesture) command)))
1333
1334 (loop for code from (char-code #\Space) to (char-code #\~)
1335 do (global-set-key (code-char code) 'com-self-insert))
1336
1337 (global-set-key #\Newline 'com-self-insert)
1338 (global-set-key #\Tab 'com-indent-line)
1339 (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
1340 (global-set-key '(#\j :control) 'com-newline-and-indent)
1341 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
1342 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
1343 (global-set-key '(#\a :control) 'com-beginning-of-line)
1344 (global-set-key '(#\e :control) 'com-end-of-line)
1345 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
1346 (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
1347 (global-set-key '(#\l :control) 'com-full-redisplay)
1348 (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
1349 (global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*))
1350 (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
1351 (global-set-key '(#\t :control) 'com-transpose-objects)
1352 (global-set-key '(#\Space :control) 'com-set-mark)
1353 (global-set-key '(#\y :control) 'com-yank)
1354 (global-set-key '(#\w :control) 'com-cut-out)
1355 (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1356 (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
1357 (global-set-key '(#\t :meta) 'com-transpose-words)
1358 (global-set-key '(#\u :meta) 'com-upcase-word)
1359 (global-set-key '(#\l :meta) 'com-downcase-word)
1360 (global-set-key '(#\c :meta) 'com-capitalize-word)
1361 (global-set-key '(#\x :meta) 'com-extended-command)
1362 (global-set-key '(#\y :meta) 'com-rotate-yank)
1363 (global-set-key '(#\w :meta) 'com-copy-out)
1364 (global-set-key '(#\v :control) 'com-page-down)
1365 (global-set-key '(#\v :meta) 'com-page-up)
1366 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
1367 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
1368 (global-set-key '(#\m :meta) 'com-back-to-indentation)
1369 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1370 (global-set-key '(#\q :meta) 'com-fill-paragraph)
1371 (global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*))
1372 (global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*))
1373 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1374 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
1375 (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
1376 (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1377 (global-set-key '(#\r :control) 'com-isearch-mode-backward)
1378 (global-set-key '(#\% :shift :meta) 'com-query-replace)
1379
1380 (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*))
1381 (global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*))
1382 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
1383 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
1384 (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
1385 (global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*))
1386 (global-set-key '(:home) 'com-beginning-of-line)
1387 (global-set-key '(:end) 'com-end-of-line)
1388 (global-set-key '(:prior) 'com-page-up)
1389 (global-set-key '(:next) 'com-page-down)
1390 (global-set-key '(:home :control) 'com-beginning-of-buffer)
1391 (global-set-key '(:end :control) 'com-end-of-buffer)
1392 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
1393 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
1394
1395 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1396
1397 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1398 ;;;
1399 ;;; C-x command table
1400
1401 (make-command-table 'c-x-climacs-table :errorp nil)
1402
1403 (add-menu-item-to-command-table 'global-climacs-table "C-x"
1404 :menu 'c-x-climacs-table
1405 :keystroke '(#\x :control))
1406
1407 (defun c-x-set-key (gesture command)
1408 (add-command-to-command-table command 'c-x-climacs-table
1409 :keystroke gesture :errorp nil))
1410
1411 (c-x-set-key '(#\0) 'com-delete-window)
1412 (c-x-set-key '(#\1) 'com-single-window)
1413 (c-x-set-key '(#\2) 'com-split-window-vertically)
1414 (c-x-set-key '(#\3) 'com-split-window-horizontally)
1415 (c-x-set-key '(#\() 'com-start-kbd-macro)
1416 (c-x-set-key '(#\)) 'com-end-kbd-macro)
1417 (c-x-set-key '(#\b) 'com-switch-to-buffer)
1418 (c-x-set-key '(#\e) 'com-call-last-kbd-macro)
1419 (c-x-set-key '(#\c :control) 'com-quit)
1420 (c-x-set-key '(#\f :control) 'com-find-file)
1421 (c-x-set-key '(#\k) 'com-kill-buffer)
1422 (c-x-set-key '(#\l :control) 'com-load-file)
1423 (c-x-set-key '(#\o) 'com-other-window)
1424 (c-x-set-key '(#\r) 'com-redo)
1425 (c-x-set-key '(#\u) 'com-undo)
1426 (c-x-set-key '(#\s :control) 'com-save-buffer)
1427 (c-x-set-key '(#\t :control) 'com-transpose-lines)
1428 (c-x-set-key '(#\w :control) 'com-write-buffer)
1429 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
1430
1431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1432 ;;;
1433 ;;; Some Unicode stuff
1434
1435 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
1436 (insert-object (point (current-window)) (code-char code)))
1437
1438 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1439 ;;;
1440 ;;; Dead-acute command table
1441
1442 (make-command-table 'dead-acute-climacs-table :errorp nil)
1443
1444 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
1445 :menu 'dead-acute-climacs-table
1446 :keystroke '(:dead--acute))
1447
1448 (defun dead-acute-set-key (gesture command)
1449 (add-command-to-command-table command 'dead-acute-climacs-table
1450 :keystroke gesture :errorp nil))
1451
1452 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
1453 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
1454 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
1455 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
1456 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
1457 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
1458 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
1459 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
1460 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
1461 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
1462 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
1463 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
1464 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
1465 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
1466 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
1467 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
1468 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
1469 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
1470 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
1471 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
1472
1473 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
1474
1475 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
1476 :menu 'dead-acute-dead-accute-climacs-table
1477 :keystroke '(:dead--acute))
1478
1479 (defun dead-acute-dead-accute-set-key (gesture command)
1480 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
1481 :keystroke gesture :errorp nil))
1482
1483 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
1484 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
1485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1486 ;;;
1487 ;;; Dead-grave command table
1488
1489 (make-command-table 'dead-grave-climacs-table :errorp nil)
1490
1491 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
1492 :menu 'dead-grave-climacs-table
1493 :keystroke '(:dead--grave))
1494
1495 (defun dead-grave-set-key (gesture command)
1496 (add-command-to-command-table command 'dead-grave-climacs-table
1497 :keystroke gesture :errorp nil))
1498
1499 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
1500 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
1501 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
1502 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
1503 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
1504 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
1505 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
1506 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
1507 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
1508 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
1509 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
1510
1511 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1512 ;;;
1513 ;;; Dead-diaeresis command table
1514
1515 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
1516
1517 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
1518 :menu 'dead-diaeresis-climacs-table
1519 :keystroke '(:dead--diaeresis :shift))
1520
1521 (defun dead-diaeresis-set-key (gesture command)
1522 (add-command-to-command-table command 'dead-diaeresis-climacs-table
1523 :keystroke gesture :errorp nil))
1524
1525 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
1526 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
1527 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
1528 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
1529 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
1530 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
1531 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
1532 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
1533 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
1534 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
1535 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
1536 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
1537
1538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1539 ;;;
1540 ;;; Dead-tilde command table
1541
1542 (make-command-table 'dead-tilde-climacs-table :errorp nil)
1543
1544 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1545 :menu 'dead-tilde-climacs-table
1546 :keystroke '(:dead--tilde :shift))
1547
1548 (defun dead-tilde-set-key (gesture command)
1549 (add-command-to-command-table command 'dead-tilde-climacs-table
1550 :keystroke gesture :errorp nil))
1551
1552 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1553 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1554 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1555 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1556 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1557 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1558 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1559 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1560 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1561 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1562 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1563
1564 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1565 ;;;
1566 ;;; Dead-circumflex command table
1567
1568 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1569
1570 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1571 :menu 'dead-circumflex-climacs-table
1572 :keystroke '(:dead--circumflex :shift))
1573
1574 (defun dead-circumflex-set-key (gesture command)
1575 (add-command-to-command-table command 'dead-circumflex-climacs-table
1576 :keystroke gesture :errorp nil))
1577
1578 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1579 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1580 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1581 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1582 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1583 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1584 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1585 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1586 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1587 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1588 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
1589
1590 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1591 ;;;
1592 ;;; Isearch command table
1593
1594 (make-command-table 'isearch-climacs-table :errorp nil)
1595
1596 (defun isearch-set-key (gesture command)
1597 (add-command-to-command-table command 'isearch-climacs-table
1598 :keystroke gesture :errorp nil))
1599
1600 (loop for code from (char-code #\Space) to (char-code #\~)
1601 do (isearch-set-key (code-char code) 'com-isearch-append-char))
1602
1603 (isearch-set-key '(#\Newline) 'com-isearch-exit)
1604 (isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
1605 (isearch-set-key '(#\s :control) 'com-isearch-forward)
1606 (isearch-set-key '(#\r :control) 'com-isearch-backward)
1607
1608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1609 ;;;
1610 ;;; Query replace command table
1611
1612 (make-command-table 'query-replace-climacs-table :errorp nil)
1613
1614 (defun query-replace-set-key (gesture command)
1615 (add-command-to-command-table command 'query-replace-climacs-table
1616 :keystroke gesture :errorp nil))
1617
1618 (query-replace-set-key '(#\Newline) 'com-query-replace-exit)
1619 (query-replace-set-key '(#\Space) 'com-query-replace-replace)
1620 (query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
1621 (query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
1622 (query-replace-set-key '(#\q) 'com-query-replace-exit)
1623 (query-replace-set-key '(#\y) 'com-query-replace-replace)
1624 (query-replace-set-key '(#\n) 'com-query-replace-skip)

  ViewVC Help
Powered by ViewVC 1.1.5