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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations)
Wed Jan 12 16:41:16 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.61: +57 -52 lines
  * added numeric arguments.  This feature requires a CVS version of McCLIM as
    of 2005-01-11.  Only a few commands take numeric arguments at the moment
    such as forward-object, backward-object, delete-object, and
    backward-delete-object.  There are more to come.

  * the cursor display problem has been "fixed" by drawing a rectangle rather than
    a line.  This makes obsolete the hacky code for explicit rounding of cursor
    coordinates.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; GUI for the Climacs editor.
24
25 (in-package :climacs-gui)
26
27 (defclass filename-mixin ()
28 ((filename :initform nil :accessor filename)))
29
30 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin)
31 ((needs-saving :initform nil :accessor needs-saving))
32 (:default-initargs :name "*scratch*"))
33
34
35 (defclass climacs-pane (application-pane)
36 ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
37 (point :initform nil :initarg :point :reader point)
38 (syntax :initarg :syntax :accessor syntax)
39 (mark :initform nil :initarg :mark :reader mark)
40 ;; allows a certain number of commands to have some minimal memory
41 (previous-command :initform nil :accessor previous-command)
42 ;; for next-line and previous-line commands
43 (goal-column :initform nil)
44 ;; for dynamic abbrev expansion
45 (original-prefix :initform nil)
46 (prefix-start-offset :initform nil)
47 (dabbrev-expansion-mark :initform nil)))
48
49 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
50 (declare (ignore args))
51 (with-slots (buffer point syntax mark) pane
52 (when (null point)
53 (setf point (make-instance 'standard-right-sticky-mark
54 :buffer buffer)))
55 (when (null mark)
56 (setf mark (make-instance 'standard-right-sticky-mark
57 :buffer buffer)))
58 (setf syntax (make-instance 'texinfo-syntax :pane pane))))
59
60 (defclass minibuffer-pane (application-pane) ())
61
62 (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
63 (declare (ignore type args))
64 (window-clear pane))
65
66 (define-application-frame climacs ()
67 ((win :reader win))
68 (:panes
69 (win (make-pane 'climacs-pane
70 :width 900 :height 400
71 :name 'win
72 :incremental-redisplay t
73 :display-function 'display-win))
74
75 (info :application
76 :width 900 :height 20 :max-height 20
77 :name 'info :background +light-gray+
78 :scroll-bars nil
79 :borders nil
80 :incremental-redisplay t
81 :display-function 'display-info)
82 (int (make-pane 'minibuffer-pane
83 :width 900 :height 20 :max-height 20 :min-height 20
84 :scroll-bars nil)))
85 (:layouts
86 (default
87 (vertically (:scroll-bars nil)
88 (scrolling (:width 900 :height 400) win)
89 info
90 int))
91 (without-interactor
92 (vertically (:scroll-bars nil)
93 (scrolling (:width 900 :height 400) win)
94 info)))
95 (:top-level (climacs-top-level)))
96
97 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
98 (declare (ignore args))
99 (clear-modify (buffer (win frame))))
100
101 (defun climacs ()
102 "Starts up a climacs session"
103 (let ((frame (make-application-frame 'climacs)))
104 (run-frame-top-level frame)))
105
106 (defun display-message (format-string &rest format-args)
107 (apply #'format *standard-input* format-string format-args))
108
109 (defvar *overwrite-mode* nil)
110
111 (defun display-info (frame pane)
112 (let* ((win (win frame))
113 (buf (buffer win))
114 (name-info (format nil " ~a ~a Syntax: ~a ~a"
115 (if (needs-saving buf) "**" "--")
116 (name buf)
117 (name (syntax win))
118 (if *overwrite-mode*
119 "Ovwrt"
120 ""))))
121 (princ name-info pane)))
122
123 (defun display-win (frame pane)
124 "The display function used by the climacs application frame."
125 (declare (ignore frame))
126 (redisplay-pane pane))
127
128 (defun find-gestures (gestures start-table)
129 (loop with table = (find-command-table start-table)
130 for (gesture . rest) on gestures
131 for item = (find-keystroke-item gesture table :errorp nil)
132 while item
133 do (if (eq (command-menu-item-type item) :command)
134 (return (if (null rest) item nil))
135 (setf table (command-menu-item-value item)))
136 finally (return item)))
137
138 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
139 (defparameter *current-gesture* nil)
140
141 (defun meta-digit (gesture)
142 (position gesture
143 '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
144 (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
145 :test #'event-matches-gesture-name-p))
146
147 (defun climacs-read-gesture ()
148 (loop for gesture = (read-gesture :stream *standard-input*)
149 when (event-matches-gesture-name-p gesture '(#\g :control))
150 do (throw 'outer-loop nil)
151 until (or (characterp gesture)
152 (and (typep gesture 'keyboard-event)
153 (or (keyboard-event-character gesture)
154 (not (member (keyboard-event-key-name
155 gesture)
156 '(:control-left :control-right
157 :shift-left :shift-right
158 :meta-left :meta-right
159 :super-left :super-right
160 :hyper-left :hyper-right
161 :shift-lock :caps-lock
162 :alt-left :alt-right))))))
163 finally (return gesture)))
164
165 (defun read-numeric-argument (&key (stream *standard-input*))
166 (let ((gesture (climacs-read-gesture)))
167 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
168 (let ((numarg 4))
169 (loop for gesture = (climacs-read-gesture)
170 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
171 do (setf numarg (* 4 numarg))
172 finally (unread-gesture gesture :stream stream))
173 (let ((gesture (climacs-read-gesture)))
174 (cond ((and (characterp gesture)
175 (digit-char-p gesture 10))
176 (setf numarg (- (char-code gesture) (char-code #\0)))
177 (loop for gesture = (climacs-read-gesture)
178 while (and (characterp gesture)
179 (digit-char-p gesture 10))
180 do (setf numarg (+ (* 10 numarg)
181 (- (char-code gesture) (char-code #\0))))
182 finally (unread-gesture gesture :stream stream)
183 (return (values numarg t))))
184 (t
185 (unread-gesture gesture :stream stream)
186 (values numarg t))))))
187 ((meta-digit gesture)
188 (let ((numarg (meta-digit gesture)))
189 (loop for gesture = (climacs-read-gesture)
190 while (meta-digit gesture)
191 do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
192 finally (unread-gesture gesture :stream stream)
193 (return (values numarg t)))))
194 (t (unread-gesture gesture :stream stream)
195 (values 1 nil)))))
196
197 (defun climacs-top-level (frame &key
198 command-parser command-unparser
199 partial-command-parser prompt)
200 (declare (ignore command-parser command-unparser partial-command-parser prompt))
201 (setf (slot-value frame 'win) (find-pane-named frame 'win))
202 (let ((*standard-output* (find-pane-named frame 'win))
203 (*standard-input* (find-pane-named frame 'int))
204 (*print-pretty* nil)
205 (*abort-gestures* nil))
206 (redisplay-frame-panes frame :force-p t)
207 (loop (catch 'outer-loop
208 (loop for gestures = '()
209 for numarg = (read-numeric-argument :stream *standard-input*)
210 do (loop (setf *current-gesture* (climacs-read-gesture))
211 (setf gestures (nconc gestures (list *current-gesture*)))
212 (let ((item (find-gestures gestures 'global-climacs-table)))
213 (cond ((not item)
214 (beep) (return))
215 ((eq (command-menu-item-type item) :command)
216 (let ((command (command-menu-item-value item)))
217 (unless (consp command)
218 (setf command (list command)))
219 (setf command (substitute-numeric-argument-marker command numarg))
220 (handler-case
221 (execute-frame-command frame command)
222 (error (condition)
223 (beep)
224 (format *error-output* "~a~%" condition)))
225 (setf (previous-command *standard-output*)
226 (if (consp command)
227 (car command)
228 command))
229 (return)))
230 (t nil))))
231 (let ((buffer (buffer (win frame))))
232 (when (modified-p buffer)
233 (setf (needs-saving buffer) t)))
234 (redisplay-frame-panes frame)))
235 (beep)
236 (let ((buffer (buffer (win frame))))
237 (when (modified-p buffer)
238 (setf (needs-saving buffer) t)))
239 (redisplay-frame-panes frame))))
240
241 (defmacro define-named-command (command-name args &body body)
242 `(define-climacs-command ,(if (listp command-name)
243 `(,@command-name :name t)
244 `(,command-name :name t)) ,args ,@body))
245
246 (define-named-command (com-quit) ()
247 (frame-exit *application-frame*))
248
249 (define-named-command com-toggle-overwrite-mode ()
250 (setf *overwrite-mode* (not *overwrite-mode*)))
251
252 (define-command com-self-insert ()
253 (let ((point (point (win *application-frame*))))
254 (unless (constituentp *current-gesture*)
255 (possibly-expand-abbrev point))
256 (if (and *overwrite-mode* (not (end-of-line-p point)))
257 (progn
258 (delete-range point)
259 (insert-object point *current-gesture*))
260 (insert-object point *current-gesture*))))
261
262 (define-named-command com-beginning-of-line ()
263 (beginning-of-line (point (win *application-frame*))))
264
265 (define-named-command com-end-of-line ()
266 (end-of-line (point (win *application-frame*))))
267
268 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
269 (delete-range (point (win *application-frame*)) count))
270
271 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
272 (delete-range (point (win *application-frame*)) (- count)))
273
274 (define-named-command com-transpose-objects ()
275 (let* ((point (point (win *application-frame*))))
276 (unless (beginning-of-buffer-p point)
277 (when (end-of-line-p point)
278 (backward-object point))
279 (let ((object (object-after point)))
280 (delete-range point)
281 (backward-object point)
282 (insert-object point object)
283 (forward-object point)))))
284
285 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
286 (backward-object (point (win *application-frame*)) count))
287
288 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
289 (forward-object (point (win *application-frame*)) count))
290
291 (define-named-command com-transpose-words ()
292 (let* ((point (point (win *application-frame*))))
293 (let (bw1 bw2 ew1 ew2)
294 (backward-word point)
295 (setf bw1 (offset point))
296 (forward-word point)
297 (setf ew1 (offset point))
298 (forward-word point)
299 (when (= (offset point) ew1)
300 ;; this is emacs' message in the minibuffer
301 (error "Don't have two things to transpose"))
302 (setf ew2 (offset point))
303 (backward-word point)
304 (setf bw2 (offset point))
305 (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
306 (w1 (buffer-sequence (buffer point) bw1 ew1)))
307 (delete-word point)
308 (insert-sequence point w1)
309 (backward-word point)
310 (backward-word point)
311 (delete-word point)
312 (insert-sequence point w2)
313 (forward-word point)))))
314
315 (define-named-command com-transpose-lines ()
316 (let ((point (point (win *application-frame*))))
317 (beginning-of-line point)
318 (unless (beginning-of-buffer-p point)
319 (previous-line point))
320 (let* ((bol (offset point))
321 (eol (progn (end-of-line point)
322 (offset point)))
323 (line (buffer-sequence (buffer point) bol eol)))
324 (delete-region bol point)
325 ;; Remove newline at end of line as well.
326 (unless (end-of-buffer-p point)
327 (delete-range point))
328 ;; If the current line is at the end of the buffer, we want to
329 ;; be able to insert past it, so we need to get an extra line
330 ;; at the end.
331 (when (progn (end-of-line point)
332 (end-of-buffer-p point))
333 (insert-object point #\Newline))
334 (next-line point)
335 (insert-sequence point line)
336 (insert-object point #\Newline))))
337
338 (define-named-command com-previous-line ()
339 (let* ((win (win *application-frame*))
340 (point (point win)))
341 (unless (or (eq (previous-command win) 'com-previous-line)
342 (eq (previous-command win) 'com-next-line))
343 (setf (slot-value win 'goal-column) (column-number point)))
344 (previous-line point (slot-value win 'goal-column))))
345
346 (define-named-command com-next-line ()
347 (let* ((win (win *application-frame*))
348 (point (point win)))
349 (unless (or (eq (previous-command win) 'com-previous-line)
350 (eq (previous-command win) 'com-next-line))
351 (setf (slot-value win 'goal-column) (column-number point)))
352 (next-line point (slot-value win 'goal-column))))
353
354 (define-named-command com-open-line ()
355 (open-line (point (win *application-frame*))))
356
357 (define-named-command com-kill-line ()
358 (let* ((pane (win *application-frame*))
359 (point (point pane))
360 (mark (offset point)))
361 (cond ((end-of-buffer-p point) nil)
362 ((end-of-line-p point)(forward-object point))
363 (t
364 (end-of-line point)
365 (cond ((beginning-of-buffer-p point) nil)
366 ((beginning-of-line-p point)(forward-object point)))))
367 (if (eq (previous-command pane) 'com-kill-line)
368 (kill-ring-concatenating-push *kill-ring*
369 (region-to-sequence mark point))
370 (kill-ring-standard-push *kill-ring*
371 (region-to-sequence mark point)))
372 (delete-region mark point)))
373
374 (define-named-command com-forward-word ()
375 (forward-word (point (win *application-frame*))))
376
377 (define-named-command com-backward-word ()
378 (backward-word (point (win *application-frame*))))
379
380 (define-named-command com-delete-word ()
381 (delete-word (point (win *application-frame*))))
382
383 (define-named-command com-backward-delete-word ()
384 (backward-delete-word (point (win *application-frame*))))
385
386 (define-named-command com-upcase-word ()
387 (upcase-word (point (win *application-frame*))))
388
389 (define-named-command com-downcase-word ()
390 (downcase-word (point (win *application-frame*))))
391
392 (define-named-command com-capitalize-word ()
393 (capitalize-word (point (win *application-frame*))))
394
395 (define-named-command com-toggle-layout ()
396 (setf (frame-current-layout *application-frame*)
397 (if (eq (frame-current-layout *application-frame*) 'default)
398 'without-interactor
399 'default)))
400
401 (define-command com-extended-command ()
402 (let ((item (accept 'command :prompt "Extended Command")))
403 (execute-frame-command *application-frame* item)))
404
405 (eval-when (:compile-toplevel :load-toplevel)
406 (define-presentation-type completable-pathname ()
407 :inherit-from 'pathname))
408
409 (defun filename-completer (so-far mode)
410 (flet ((remove-trail (s)
411 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
412 (if pos (1+ pos) 0)))))
413 (let* ((directory-prefix
414 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
415 ""
416 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
417 (full-so-far (concatenate 'string directory-prefix so-far))
418 (pathnames
419 (loop with length = (length full-so-far)
420 for path in (directory (concatenate 'string
421 (remove-trail so-far)
422 "*.*"))
423 when (let ((mismatch (mismatch (namestring path) full-so-far)))
424 (or (null mismatch) (= mismatch length)))
425 collect path))
426 (strings (mapcar #'namestring pathnames))
427 (first-string (car strings))
428 (length-common-prefix nil)
429 (completed-string nil)
430 (full-completed-string nil))
431 (unless (null pathnames)
432 (setf length-common-prefix
433 (loop with length = (length first-string)
434 for string in (cdr strings)
435 do (setf length (min length (or (mismatch string first-string) length)))
436 finally (return length))))
437 (unless (null pathnames)
438 (setf completed-string
439 (subseq first-string (length directory-prefix)
440 (if (null (cdr pathnames)) nil length-common-prefix)))
441 (setf full-completed-string
442 (concatenate 'string directory-prefix completed-string)))
443 (case mode
444 ((:complete-limited :complete-maximal)
445 (cond ((null pathnames)
446 (values so-far nil nil 0 nil))
447 ((null (cdr pathnames))
448 (values completed-string t (car pathnames) 1 nil))
449 (t
450 (values completed-string nil nil (length pathnames) nil))))
451 (:complete
452 (cond ((null pathnames)
453 (values so-far t so-far 1 nil))
454 ((null (cdr pathnames))
455 (values completed-string t (car pathnames) 1 nil))
456 ((find full-completed-string strings :test #'string-equal)
457 (let ((pos (position full-completed-string strings :test #'string-equal)))
458 (values completed-string
459 t (elt pathnames pos) (length pathnames) nil)))
460 (t
461 (values completed-string nil nil (length pathnames) nil))))
462 (:possibilities
463 (values nil nil nil (length pathnames)
464 (loop with length = (length directory-prefix)
465 for name in pathnames
466 collect (list (subseq (namestring name) length nil)
467 name))))))))
468
469 (define-presentation-method accept
470 ((type completable-pathname) stream (view textual-view) &key)
471 (multiple-value-bind (pathname success string)
472 (complete-input stream
473 #'filename-completer
474 :partial-completers '(#\Space)
475 :allow-any-input t)
476 (declare (ignore success))
477 (or pathname string)))
478
479 (defun pathname-filename (pathname)
480 (if (null (pathname-type pathname))
481 (pathname-name pathname)
482 (concatenate 'string (pathname-name pathname)
483 "." (pathname-type pathname))))
484
485 (define-named-command com-find-file ()
486 (let ((filename (accept 'completable-pathname
487 :prompt "Find File")))
488 (with-slots (buffer point syntax) (win *application-frame*)
489 (setf buffer (make-instance 'climacs-buffer)
490 point (make-instance 'standard-right-sticky-mark :buffer buffer)
491 syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
492 (with-open-file (stream filename :direction :input :if-does-not-exist :create)
493 (input-from-stream stream buffer 0))
494 (setf (filename buffer) filename
495 (name buffer) (pathname-filename filename)
496 (needs-saving buffer) nil)
497 (beginning-of-buffer point)
498 ;; this one is needed so that the buffer modification protocol
499 ;; resets the low and high marks after redisplay
500 (redisplay-frame-panes *application-frame*))))
501
502 (define-named-command com-save-buffer ()
503 (let* ((buffer (buffer (win *application-frame*)))
504 (filename (or (filename buffer)
505 (accept 'completable-pathname
506 :prompt "Save Buffer to File"))))
507 (if (or (null (filename buffer))
508 (needs-saving buffer))
509 (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
510 (output-to-stream stream buffer 0 (size buffer)))
511 (setf (filename buffer) filename
512 (name buffer) (pathname-filename filename))
513 (display-message "Wrote: ~a" (filename buffer)))
514 (display-message "No changes need to be saved from ~a" (name buffer)))
515 (setf (needs-saving buffer) nil)))
516
517 (define-named-command com-write-buffer ()
518 (let ((filename (accept 'completable-pathname
519 :prompt "Write Buffer to File"))
520 (buffer (buffer (win *application-frame*))))
521 (with-open-file (stream filename :direction :output :if-exists :supersede)
522 (output-to-stream stream buffer 0 (size buffer)))
523 (setf (filename buffer) filename
524 (name buffer) (pathname-filename filename)
525 (needs-saving buffer) nil)
526 (display-message "Wrote: ~a" (filename buffer))))
527
528 (define-named-command com-beginning-of-buffer ()
529 (beginning-of-buffer (point (win *application-frame*))))
530
531 (define-named-command com-page-down ()
532 (let ((pane (win *application-frame*)))
533 (page-down pane (syntax pane))))
534
535 (define-named-command com-page-up ()
536 (let ((pane (win *application-frame*)))
537 (page-up pane (syntax pane))))
538
539 (define-named-command com-end-of-buffer ()
540 (end-of-buffer (point (win *application-frame*))))
541
542 (define-named-command com-back-to-indentation ()
543 (let ((point (point (win *application-frame*))))
544 (beginning-of-line point)
545 (loop until (end-of-line-p point)
546 while (whitespacep (object-after point))
547 do (incf (offset point)))))
548
549 (define-named-command com-goto-position ()
550 (setf (offset (point (win *application-frame*)))
551 (accept 'integer :prompt "Goto Position")))
552
553 (define-named-command com-goto-line ()
554 (loop with mark = (make-instance 'standard-right-sticky-mark
555 :buffer (buffer (win *application-frame*)))
556 do (end-of-line mark)
557 until (end-of-buffer-p mark)
558 repeat (accept 'integer :prompt "Goto Line")
559 do (incf (offset mark))
560 (end-of-line mark)
561 finally (beginning-of-line mark)
562 (setf (offset (point (win *application-frame*)))
563 (offset mark))))
564
565 (define-named-command com-browse-url ()
566 (accept 'url :prompt "Browse URL"))
567
568 (define-named-command com-set-mark ()
569 (with-slots (point mark) (win *application-frame*)
570 (setf mark (clone-mark point))))
571
572 (define-named-command com-exchange-point-and-mark ()
573 (with-slots (point mark) (win *application-frame*)
574 (psetf (offset mark) (offset point)
575 (offset point) (offset mark))))
576
577 (define-named-command com-set-syntax ()
578 (setf (syntax (win *application-frame*))
579 (make-instance (accept 'syntax :prompt "Set Syntax")
580 :pane (win *application-frame*))))
581
582 ;;;;;;;;;;;;;;;;;;;;
583 ;; Kill ring commands
584
585 ;; Copies an element from a kill-ring to a buffer at the given offset
586 (define-named-command com-yank ()
587 (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*)))
588
589 ;; Destructively cut a given buffer region into the kill-ring
590 (define-named-command com-cut-out ()
591 (with-slots (point mark)(win *application-frame*)
592 (cond ((< (offset mark)(offset point))
593 (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
594 (delete-region (offset mark) point))
595 (t
596 (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
597 (delete-region (offset point) mark)))))
598
599 ;; Non destructively copies in buffer region to the kill ring
600 (define-named-command com-copy-out ()
601 (with-slots (point mark)(win *application-frame*)
602 (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))))
603
604
605 (define-named-command com-rotate-yank ()
606 (let* ((pane (win *application-frame*))
607 (point (point pane))
608 (last-yank (kill-ring-yank *kill-ring*)))
609 (if (eq (previous-command pane)
610 'com-rotate-yank)
611 (progn
612 (delete-range point (* -1 (length last-yank)))
613 (rotate-yank-position *kill-ring*)))
614 (insert-sequence point (kill-ring-yank *kill-ring*))))
615
616 (define-named-command com-resize-kill-ring ()
617 (let ((size (accept 'integer :prompt "New kill ring size")))
618 (setf (kill-ring-max-size *kill-ring*) size)))
619
620 (define-named-command com-search-forward ()
621 (search-forward (point (win *application-frame*))
622 (accept 'string :prompt "Search Forward")
623 :test (lambda (a b)
624 (and (characterp b) (char-equal a b)))))
625
626 (define-named-command com-search-backward ()
627 (search-backward (point (win *application-frame*))
628 (accept 'string :prompt "Search Backward")
629 :test (lambda (a b)
630 (and (characterp b) (char-equal a b)))))
631
632 (define-named-command com-dabbrev-expand ()
633 (let* ((win (win *application-frame*))
634 (point (point win)))
635 (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
636 (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
637 (setf (offset dabbrev-expansion-mark)
638 (offset point))
639 (forward-word dabbrev-expansion-mark))
640 ((mark< dabbrev-expansion-mark point)
641 (backward-object dabbrev-expansion-mark))
642 (t (forward-object dabbrev-expansion-mark)))))
643 (unless (or (beginning-of-buffer-p point)
644 (not (constituentp (object-before point))))
645 (unless (and (eq (previous-command win) 'com-dabbrev-expand)
646 (not (null prefix-start-offset)))
647 (setf dabbrev-expansion-mark (clone-mark point))
648 (backward-word dabbrev-expansion-mark)
649 (setf prefix-start-offset (offset dabbrev-expansion-mark))
650 (setf original-prefix (region-to-sequence prefix-start-offset point))
651 (move))
652 (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
653 (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
654 (not (constituentp (object-before dabbrev-expansion-mark))))
655 (looking-at dabbrev-expansion-mark original-prefix)))
656 do (move))
657 (if (end-of-buffer-p dabbrev-expansion-mark)
658 (progn (delete-region prefix-start-offset point)
659 (insert-sequence point original-prefix)
660 (setf prefix-start-offset nil))
661 (progn (delete-region prefix-start-offset point)
662 (insert-sequence point
663 (let ((offset (offset dabbrev-expansion-mark)))
664 (prog2 (forward-word dabbrev-expansion-mark)
665 (region-to-sequence offset dabbrev-expansion-mark)
666 (setf (offset dabbrev-expansion-mark) offset))))
667 (move))))))))
668
669 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
670 ;;;
671 ;;; Global command table
672
673 (make-command-table 'global-climacs-table :errorp nil)
674
675 (defun global-set-key (gesture command)
676 (add-command-to-command-table command 'global-climacs-table
677 :keystroke gesture :errorp nil))
678
679 (loop for code from (char-code #\space) to (char-code #\~)
680 do (global-set-key (code-char code) 'com-self-insert))
681
682 (global-set-key #\newline 'com-self-insert)
683 (global-set-key #\tab 'com-self-insert)
684 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
685 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
686 (global-set-key '(#\a :control) 'com-beginning-of-line)
687 (global-set-key '(#\e :control) 'com-end-of-line)
688 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
689 (global-set-key '(#\p :control) 'com-previous-line)
690 (global-set-key '(#\n :control) 'com-next-line)
691 (global-set-key '(#\o :control) 'com-open-line)
692 (global-set-key '(#\k :control) 'com-kill-line)
693 (global-set-key '(#\t :control) 'com-transpose-objects)
694 (global-set-key '(#\Space :control) 'com-set-mark)
695 (global-set-key '(#\y :control) 'com-yank)
696 (global-set-key '(#\w :control) 'com-cut-out)
697 (global-set-key '(#\f :meta) 'com-forward-word)
698 (global-set-key '(#\b :meta) 'com-backward-word)
699 (global-set-key '(#\t :meta) 'com-transpose-words)
700 (global-set-key '(#\u :meta) 'com-upcase-word)
701 (global-set-key '(#\l :meta) 'com-downcase-word)
702 (global-set-key '(#\c :meta) 'com-capitalize-word)
703 (global-set-key '(#\x :meta) 'com-extended-command)
704 (global-set-key '(#\y :meta) 'com-rotate-yank)
705 (global-set-key '(#\w :meta) 'com-copy-out)
706 (global-set-key '(#\v :control) 'com-page-down)
707 (global-set-key '(#\v :meta) 'com-page-up)
708 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
709 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
710 (global-set-key '(#\m :meta) 'com-back-to-indentation)
711 (global-set-key '(#\d :meta) 'com-delete-word)
712 (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
713 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
714
715 (global-set-key '(:up) 'com-previous-line)
716 (global-set-key '(:down) 'com-next-line)
717 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
718 (global-set-key '(:right) `(com-forward-object *numeric-argument-marker*))
719 (global-set-key '(:left :control) 'com-backward-word)
720 (global-set-key '(:right :control) 'com-forward-word)
721 (global-set-key '(:home) 'com-beginning-of-line)
722 (global-set-key '(:end) 'com-end-of-line)
723 (global-set-key '(:prior) 'com-page-up)
724 (global-set-key '(:next) 'com-page-down)
725 (global-set-key '(:home :control) 'com-beginning-of-buffer)
726 (global-set-key '(:end :control) 'com-end-of-buffer)
727 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
728 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
729
730 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
731
732 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
733 ;;;
734 ;;; C-x command table
735
736 (make-command-table 'c-x-climacs-table :errorp nil)
737
738 (add-menu-item-to-command-table 'global-climacs-table "C-x"
739 :menu 'c-x-climacs-table
740 :keystroke '(#\x :control))
741
742 (defun c-x-set-key (gesture command)
743 (add-command-to-command-table command 'c-x-climacs-table
744 :keystroke gesture :errorp nil))
745
746 (c-x-set-key '(#\c :control) 'com-quit)
747 (c-x-set-key '(#\f :control) 'com-find-file)
748 (c-x-set-key '(#\s :control) 'com-save-buffer)
749 (c-x-set-key '(#\t :control) 'com-transpose-lines)
750 (c-x-set-key '(#\w :control) 'com-write-buffer)
751 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
752
753 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
754 ;;;
755 ;;; Some Unicode stuff
756
757 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
758 (insert-object (point (win *application-frame*)) (code-char code)))
759
760 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
761 ;;;
762 ;;; Dead-acute command table
763
764 (make-command-table 'dead-acute-climacs-table :errorp nil)
765
766 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
767 :menu 'dead-acute-climacs-table
768 :keystroke '(:dead--acute))
769
770 (defun dead-acute-set-key (gesture command)
771 (add-command-to-command-table command 'dead-acute-climacs-table
772 :keystroke gesture :errorp nil))
773
774 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
775 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
776 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
777 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
778 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
779 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
780 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
781 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
782 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
783 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
784 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
785 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
786 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
787 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
788 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
789 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
790 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
791 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
792 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
793 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
794
795 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
796
797 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
798 :menu 'dead-acute-dead-accute-climacs-table
799 :keystroke '(:dead--acute))
800
801 (defun dead-acute-dead-accute-set-key (gesture command)
802 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
803 :keystroke gesture :errorp nil))
804
805 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
806 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
807 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
808 ;;;
809 ;;; Dead-grave command table
810
811 (make-command-table 'dead-grave-climacs-table :errorp nil)
812
813 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
814 :menu 'dead-grave-climacs-table
815 :keystroke '(:dead--grave))
816
817 (defun dead-grave-set-key (gesture command)
818 (add-command-to-command-table command 'dead-grave-climacs-table
819 :keystroke gesture :errorp nil))
820
821 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
822 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
823 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
824 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
825 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
826 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
827 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
828 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
829 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
830 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
831 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
832
833 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
834 ;;;
835 ;;; Dead-diaeresis command table
836
837 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
838
839 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
840 :menu 'dead-diaeresis-climacs-table
841 :keystroke '(:dead--diaeresis :shift))
842
843 (defun dead-diaeresis-set-key (gesture command)
844 (add-command-to-command-table command 'dead-diaeresis-climacs-table
845 :keystroke gesture :errorp nil))
846
847 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
848 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
849 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
850 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
851 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
852 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
853 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
854 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
855 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
856 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
857 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
858 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
859
860 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
861 ;;;
862 ;;; Dead-tilde command table
863
864 (make-command-table 'dead-tilde-climacs-table :errorp nil)
865
866 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
867 :menu 'dead-tilde-climacs-table
868 :keystroke '(:dead--tilde :shift))
869
870 (defun dead-tilde-set-key (gesture command)
871 (add-command-to-command-table command 'dead-tilde-climacs-table
872 :keystroke gesture :errorp nil))
873
874 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
875 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
876 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
877 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
878 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
879 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
880 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
881 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
882 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
883 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
884 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
885
886 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
887 ;;;
888 ;;; Dead-circumflex command table
889
890 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
891
892 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
893 :menu 'dead-circumflex-climacs-table
894 :keystroke '(:dead--circumflex :shift))
895
896 (defun dead-circumflex-set-key (gesture command)
897 (add-command-to-command-table command 'dead-circumflex-climacs-table
898 :keystroke gesture :errorp nil))
899
900 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
901 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
902 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
903 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
904 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
905 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
906 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
907 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
908 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
909 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
910 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5