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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5