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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5