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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.138 - (show annotations)
Tue May 10 16:28:53 2005 UTC (8 years, 11 months ago) by crhodes
Branch: MAIN
Changes since 1.137: +2 -2 lines
Restore the (in-package ...) and the copyright information to
buffer.lisp

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

  ViewVC Help
Powered by ViewVC 1.1.5