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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5