January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/buffer.lisp
by rstrandh＠common-lisp.net 05 Jan '05

05 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24863 Modified Files: buffer.lisp Log Message: Fixed some code that was not great, and modified the name of a reader function of the no-such-offset condition that made a bug in CMUCL manifest itself and made it impossible to run Climacs. Date: Wed Jan 5 22:39:24 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.15 climacs/buffer.lisp:1.16 --- climacs/buffer.lisp:1.15 Wed Jan 5 00:07:34 2005 +++ climacs/buffer.lisp Wed Jan 5 22:39:23 2005 @@ -76,10 +76,10 @@ (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) -(defmethod offset (mark) +(defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) -(defmethod (setf offset) (new-offset mark) +(defmethod (setf offset) (new-offset (mark mark-mixin)) (assert (<= 0 new-offset (size (buffer mark))) () (make-condition 'no-such-offset :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) @@ -129,9 +129,9 @@ (make-instance type :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) - ((offset :reader offset :initarg :offset)) + ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) - (format stream "No such offset: ~a" (offset condition)))) + (format stream "No such offset: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made at an operation that is before the beginning or after the end of the buffer."))

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 05 Jan '05

05 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7326 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Added (non-incremental for now) search functions. Date: Wed Jan 5 06:09:04 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.9 climacs/base.lisp:1.10 --- climacs/base.lisp:1.9 Sat Jan 1 10:34:25 2005 +++ climacs/base.lisp Wed Jan 5 06:09:04 2005 @@ -144,3 +144,53 @@ (defclass name-mixin () ((name :initarg :name :accessor name))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Search + +(defun buffer-looking-at (buffer offset vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR at OFFSET" + (and (<= (+ offset (length vector)) (size buffer)) + (loop for i from offset + for obj across vector + unless (funcall test (buffer-object buffer i) obj) + return nil + finally (return t)))) + +(defun looking-at (mark vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR after MARK" + (buffer-looking-at (buffer mark) (offset mark) vector :test test)) + + +(defun buffer-search-forward (buffer offset vector &key (test #'eql)) + "return the smallest offset of BUFFER >= OFFSET containing VECTOR +or NIL if no such offset exists" + (loop for i from offset to (size buffer) + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + + +(defun buffer-search-backward (buffer offset vector &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length VECTOR)) +containing VECTOR or NIL if no such offset exists" + (loop for i downfrom (- offset (length vector)) to 0 + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + +(defun search-forward (mark vector &key (test #'eql)) + "move MARK forward after the first occurence of VECTOR after MARK" + (let ((offset (buffer-search-forward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) (+ offset (length vector)))))) + +(defun search-backward (mark vector &key (test #'eql)) + "move MARK backward before the first occurence of VECTOR before MARK" + (let ((offset (buffer-search-backward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) offset)))) + + Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.46 climacs/gui.lisp:1.47 --- climacs/gui.lisp:1.46 Mon Jan 3 14:36:34 2005 +++ climacs/gui.lisp Wed Jan 5 06:09:04 2005 @@ -129,19 +129,37 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) +(defun climacs-read-gesture () + (loop for gesture = (read-gesture :stream *standard-input*) + when (event-matches-gesture-name-p gesture '(#\g :control)) + do (throw 'outer-loop nil) + until (or (characterp gesture) + (and (typep gesture 'keyboard-event) + (or (keyboard-event-character gesture) + (not (member (keyboard-event-key-name + gesture) + '(:control-left :control-right + :shift-left :shift-right + :meta-left :meta-right + :super-left :super-right + :hyper-left :hyper-right + :shift-lock :caps-lock + :alt-left :alt-right)))))) + finally (return gesture))) + (defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((event-matches-gesture-name-p gesture '(#\u :control)) (let ((numarg 4)) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(#\u :control)) do (setf numarg (* 4 numarg)) finally (unread-gesture gesture :stream stream)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf gesture (+ (* 10 numarg) @@ -152,7 +170,7 @@ (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (unread-gesture gesture :stream stream) @@ -170,40 +188,35 @@ (*print-pretty* nil) (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) - (loop with gestures = '() - with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) - do (setf *current-gesture* (read-gesture :stream *standard-input*)) - (when (or (characterp *current-gesture*) - (and (typep *current-gesture* 'keyboard-event) - (or (keyboard-event-character *current-gesture*) - (not (member (keyboard-event-key-name - *current-gesture*) - '(:control-left :control-right - :shift-left :shift-right - :meta-left :meta-right - :super-left :super-right - :hyper-left :hyper-right - :shift-lock :caps-lock)))))) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '()))) - (t nil)))) - (let ((buffer (buffer (win frame)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame)))) + (loop (catch 'outer-loop + (loop with gestures = '() + with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) + do (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (setf gestures '())) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf gestures '()))) + (t nil))) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame))) + (beep) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame)))) (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body)) @@ -555,6 +568,18 @@ (define-named-command com-kr-resize () (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) + +(define-named-command com-search-forward () + (search-forward (point (win *application-frame*)) + (accept 'string :prompt "Search Forward") + :test (lambda (a b) + (and (characterp b) (char-equal a b))))) + +(define-named-command com-search-backward () + (search-backward (point (win *application-frame*)) + (accept 'string :prompt "Search Backward") + :test (lambda (a b) + (and (characterp b) (char-equal a b))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.19 climacs/packages.lisp:1.20 --- climacs/packages.lisp:1.19 Sat Jan 1 11:43:39 2005 +++ climacs/packages.lisp Wed Jan 5 06:09:04 2005 @@ -49,7 +49,10 @@ #:forward-word #:backward-word #:delete-word #:backward-delete-word #:input-from-stream #:output-to-stream - #:name-mixin #:name)) + #:name-mixin #:name + #:buffer-lookin-at #:looking-at + #:buffer-search-forward #:buffer-search-backward + #:search-forward #:search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base)

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp
by abakic＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21195 Modified Files: buffer.lisp Log Message: Removed a duplicate defclass. Date: Wed Jan 5 00:07:34 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.14 climacs/buffer.lisp:1.15 --- climacs/buffer.lisp:1.14 Mon Jan 3 19:15:41 2005 +++ climacs/buffer.lisp Wed Jan 5 00:07:34 2005 @@ -90,8 +90,6 @@ (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) -(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ()) - (defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args))

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by abakic＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14958 Modified Files: climacs.asd Log Message: asdf::input-files is not external (in my version). Date: Tue Jan 4 00:55:17 2005 Author: abakic Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.8 climacs/climacs.asd:1.9 --- climacs/climacs.asd:1.8 Mon Jan 3 11:25:42 2005 +++ climacs/climacs.asd Tue Jan 4 00:55:16 2005 @@ -63,7 +63,7 @@ (defmethod asdf:perform :around ((o asdf:compile-op) (c (eql (asdf:find-component (asdf:find-system :climacs) "skiplist-package")))) (cond - ((null (probe-file (first (asdf:input-files o c)))) + ((null (probe-file (first (asdf::input-files o c)))) (cerror "Retry loading climacs." "~@<You need to download & install Flexichain ~ separately! See the file INSTALL in the Climacs distribution ~

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp
by abakic＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29335 Modified Files: buffer.lisp Log Message: Very minor, cosmetic changes. Date: Mon Jan 3 19:15:41 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.13 climacs/buffer.lisp:1.14 --- climacs/buffer.lisp:1.13 Wed Dec 29 07:58:53 2004 +++ climacs/buffer.lisp Mon Jan 3 19:15:41 2005 @@ -339,7 +339,7 @@ (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) -(defgeneric insert-sequence (mark string) +(defgeneric insert-sequence (mark sequence) (:documentation "Insert the objects in the sequence at the mark. This function simply calls insert-buffer-sequence with the buffer and the position of the mark.")) @@ -482,7 +482,7 @@ (min (offset (low-mark buffer)) offset)) (setf (offset (high-mark buffer)) (max (offset (high-mark buffer)) (+ offset n))) -(setf (slot-value buffer 'modified) t)) + (setf (slot-value buffer 'modified) t)) (defgeneric clear-modify (buffer))

1 0

[climacs-cvs] CVS update: climacs/syntax.lisp
by rstrandh＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19246 Modified Files: syntax.lisp Log Message: Redisplay is much faster. Date: Mon Jan 3 16:07:09 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.18 climacs/syntax.lisp:1.19 --- climacs/syntax.lisp:1.18 Mon Jan 3 13:21:20 2005 +++ climacs/syntax.lisp Mon Jan 3 16:07:09 2005 @@ -265,10 +265,19 @@ (with-slots (top bot scan cache cursor-x cursor-y) syntax (position-window pane syntax) (compute-cache pane syntax) - (setf scan (offset top)) - (loop for id from 0 below (nb-elements cache) - do (updating-output (pane :unique-id id) - (display-line pane syntax (element* cache id)))) + (loop with start-offset = (offset top) + for id from 0 below (nb-elements cache) + do (setf scan start-offset) + (updating-output + (pane :unique-id id + :cache-value (if (<= start-offset + (offset (point pane)) + (+ start-offset (length (element* cache id)))) + (cons nil nil) + (element* cache id)) + :cache-test #'eq) + (display-line pane syntax (element* cache id))) + (incf start-offset (1+ (length (element* cache id))))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: gui.lisp Log Message: a very small fix. Fixnum was a bad choice here. Integer works much nicer Date: Mon Jan 3 14:36:34 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.45 climacs/gui.lisp:1.46 --- climacs/gui.lisp:1.45 Mon Jan 3 13:21:19 2005 +++ climacs/gui.lisp Mon Jan 3 14:36:34 2005 @@ -553,7 +553,7 @@ ;; Not bound to a key yet (define-named-command com-kr-resize () - (let ((size (accept 'fixnum :prompt "New kill ring size: "))) + (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10659 Modified Files: gui.lisp syntax.lisp Log Message: 2005-01-02 Lawrence Mitchell <wence(a)gmx.li> * gui.lisp ((define-application-frame climacs)): Add a without-interactor clause to the frame :layout. This is a layout without a minibuffer pane. (com-toggle-layout): Toggle layout between 'default and 'without-interactor. Note the without-interactor layout no longer allows you to enter extended commands (there's nowhere for *standard-input* to go) so I'm not sure how useful it is. (com-set-mark): Fix indentation. (com-exchange-point-and-mark): New command, exchange the positions of point and mark, bound to C-x C-x. (com-transpose-lines): New command, bound to C-x C-t. * syntax.lisp (present-contents): Fix typo in argument list. Date: Mon Jan 3 13:21:20 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.44 climacs/gui.lisp:1.45 --- climacs/gui.lisp:1.44 Mon Jan 3 11:25:43 2005 +++ climacs/gui.lisp Mon Jan 3 13:21:19 2005 @@ -77,7 +77,11 @@ (vertically (:scroll-bars nil) (scrolling (:width 900 :height 400) win) info - int))) + int)) + (without-interactor + (vertically (:scroll-bars nil) + (scrolling (:width 900 :height 400) win) + info))) (:top-level (climacs-top-level))) (defmethod redisplay-frame-panes :after ((frame climacs) &rest args) @@ -275,6 +279,29 @@ (insert-sequence point w2) (forward-word point))))) +(define-named-command com-transpose-lines () + (let ((point (point (win *application-frame*)))) + (beginning-of-line point) + (unless (beginning-of-buffer-p point) + (previous-line point)) + (let* ((bol (offset point)) + (eol (progn (end-of-line point) + (offset point))) + (line (buffer-sequence (buffer point) bol eol))) + (delete-region bol point) + ;; Remove newline at end of line as well. + (unless (end-of-buffer-p point) + (delete-range point)) + ;; If the current line is at the end of the buffer, we want to + ;; be able to insert past it, so we need to get an extra line + ;; at the end. + (when (progn (end-of-line point) + (end-of-buffer-p point)) + (insert-object point #\Newline)) + (next-line point) + (insert-sequence point line) + (insert-object point #\Newline)))) + (define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -302,7 +329,7 @@ (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) - 'with-interactor + 'without-interactor 'default))) (define-command com-extended-command () @@ -474,7 +501,12 @@ (define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) - (setf mark (clone-mark point)))) + (setf mark (clone-mark point)))) + +(define-named-command com-exchange-point-and-mark () + (with-slots (point mark) (win *application-frame*) + (psetf (offset mark) (offset point) + (offset point) (offset mark)))) (define-named-command com-set-syntax () (setf (syntax (win *application-frame*)) @@ -597,7 +629,9 @@ (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) +(c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) +(c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -634,8 +668,6 @@ (dead-acute-set-key '(#\y) '(com-insert-charcode 253)) (dead-acute-set-key '(#\C) '(com-insert-charcode 199)) (dead-acute-set-key '(#\c) '(com-insert-charcode 231)) -(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great -(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great (dead-acute-set-key '(#\x) '(com-insert-charcode 215)) (dead-acute-set-key '(#\-) '(com-insert-charcode 247)) (dead-acute-set-key '(#\T) '(com-insert-charcode 222)) @@ -643,6 +675,18 @@ (dead-acute-set-key '(#\s) '(com-insert-charcode 223)) (dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) +(make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute" + :menu 'dead-acute-dead-accute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-dead-accute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197)) +(dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dead-grave command table Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.17 climacs/syntax.lisp:1.18 --- climacs/syntax.lisp:1.17 Sat Jan 1 11:49:26 2005 +++ climacs/syntax.lisp Mon Jan 3 13:21:20 2005 @@ -88,7 +88,7 @@ (define-presentation-type url () :inherit-from 'string) -(defgeneric present-contents (contenst pane syntax)) +(defgeneric present-contents (contents pane syntax)) (defmethod present-contents (contents pane (syntax basic-syntax)) (unless (null contents)

1 0

[climacs-cvs] CVS update: climacs/translate.lisp
by rstrandh＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5301 Added Files: translate.lisp Log Message: replacement for CLX' and McCLIM's translate functions. Date: Mon Jan 3 11:45:47 2005 Author: rstrandh

1 0

[climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp
by rstrandh＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4300 Modified Files: climacs.asd gui.lisp Log Message: Added support for input of latin-1 characters for those who have a keyboard configured as us-international, where the following keys are dead: ' ` " ~ ^ Date: Mon Jan 3 11:25:54 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.7 climacs/climacs.asd:1.8 --- climacs/climacs.asd:1.7 Sat Jan 1 15:39:55 2005 +++ climacs/climacs.asd Mon Jan 3 11:25:42 2005 @@ -49,6 +49,7 @@ "Flexichain/utilities" "Flexichain/flexichain" "Flexichain/flexicursor" + "translate" "packages" "buffer" "base" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.43 climacs/gui.lisp:1.44 --- climacs/gui.lisp:1.43 Sat Jan 1 20:58:40 2005 +++ climacs/gui.lisp Mon Jan 3 11:25:43 2005 @@ -598,3 +598,152 @@ (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\w :control) 'com-write-buffer) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Some Unicode stuff + +(define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) + (insert-object (point (win *application-frame*)) (code-char code))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-acute command table + +(make-command-table 'dead-acute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-acute" + :menu 'dead-acute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-set-key '(#\A) '(com-insert-charcode 193)) +(dead-acute-set-key '(#\E) '(com-insert-charcode 201)) +(dead-acute-set-key '(#\I) '(com-insert-charcode 205)) +(dead-acute-set-key '(#\O) '(com-insert-charcode 211)) +(dead-acute-set-key '(#\U) '(com-insert-charcode 218)) +(dead-acute-set-key '(#\Y) '(com-insert-charcode 221)) +(dead-acute-set-key '(#\a) '(com-insert-charcode 225)) +(dead-acute-set-key '(#\e) '(com-insert-charcode 233)) +(dead-acute-set-key '(#\i) '(com-insert-charcode 237)) +(dead-acute-set-key '(#\o) '(com-insert-charcode 243)) +(dead-acute-set-key '(#\u) '(com-insert-charcode 250)) +(dead-acute-set-key '(#\y) '(com-insert-charcode 253)) +(dead-acute-set-key '(#\C) '(com-insert-charcode 199)) +(dead-acute-set-key '(#\c) '(com-insert-charcode 231)) +(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great +(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great +(dead-acute-set-key '(#\x) '(com-insert-charcode 215)) +(dead-acute-set-key '(#\-) '(com-insert-charcode 247)) +(dead-acute-set-key '(#\T) '(com-insert-charcode 222)) +(dead-acute-set-key '(#\t) '(com-insert-charcode 254)) +(dead-acute-set-key '(#\s) '(com-insert-charcode 223)) +(dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-grave command table + +(make-command-table 'dead-grave-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-grave" + :menu 'dead-grave-climacs-table + :keystroke '(:dead--grave)) + +(defun dead-grave-set-key (gesture command) + (add-command-to-command-table command 'dead-grave-climacs-table + :keystroke gesture :errorp nil)) + +(dead-grave-set-key '(#\A) '(com-insert-charcode 192)) +(dead-grave-set-key '(#\E) '(com-insert-charcode 200)) +(dead-grave-set-key '(#\I) '(com-insert-charcode 204)) +(dead-grave-set-key '(#\O) '(com-insert-charcode 210)) +(dead-grave-set-key '(#\U) '(com-insert-charcode 217)) +(dead-grave-set-key '(#\a) '(com-insert-charcode 224)) +(dead-grave-set-key '(#\e) '(com-insert-charcode 232)) +(dead-grave-set-key '(#\i) '(com-insert-charcode 236)) +(dead-grave-set-key '(#\o) '(com-insert-charcode 242)) +(dead-grave-set-key '(#\u) '(com-insert-charcode 249)) +(dead-grave-set-key '(#\Space) '(com-insert-charcode 96)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-diaeresis command table + +(make-command-table 'dead-diaeresis-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis" + :menu 'dead-diaeresis-climacs-table + :keystroke '(:dead--diaeresis :shift)) + +(defun dead-diaeresis-set-key (gesture command) + (add-command-to-command-table command 'dead-diaeresis-climacs-table + :keystroke gesture :errorp nil)) + +(dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196)) +(dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203)) +(dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207)) +(dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214)) +(dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220)) +(dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228)) +(dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235)) +(dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239)) +(dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246)) +(dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252)) +(dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255)) +(dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-tilde command table + +(make-command-table 'dead-tilde-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-tilde" + :menu 'dead-tilde-climacs-table + :keystroke '(:dead--tilde :shift)) + +(defun dead-tilde-set-key (gesture command) + (add-command-to-command-table command 'dead-tilde-climacs-table + :keystroke gesture :errorp nil)) + +(dead-tilde-set-key '(#\A) '(com-insert-charcode 195)) +(dead-tilde-set-key '(#\N) '(com-insert-charcode 209)) +(dead-tilde-set-key '(#\a) '(com-insert-charcode 227)) +(dead-tilde-set-key '(#\n) '(com-insert-charcode 241)) +(dead-tilde-set-key '(#\E) '(com-insert-charcode 198)) +(dead-tilde-set-key '(#\e) '(com-insert-charcode 230)) +(dead-tilde-set-key '(#\D) '(com-insert-charcode 208)) +(dead-tilde-set-key '(#\d) '(com-insert-charcode 240)) +(dead-tilde-set-key '(#\O) '(com-insert-charcode 216)) +(dead-tilde-set-key '(#\o) '(com-insert-charcode 248)) +(dead-tilde-set-key '(#\Space) '(com-insert-charcode 126)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-circumflex command table + +(make-command-table 'dead-circumflex-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-circumflex" + :menu 'dead-circumflex-climacs-table + :keystroke '(:dead--circumflex :shift)) + +(defun dead-circumflex-set-key (gesture command) + (add-command-to-command-table command 'dead-circumflex-climacs-table + :keystroke gesture :errorp nil)) + +(dead-circumflex-set-key '(#\A) '(com-insert-charcode 194)) +(dead-circumflex-set-key '(#\E) '(com-insert-charcode 202)) +(dead-circumflex-set-key '(#\I) '(com-insert-charcode 206)) +(dead-circumflex-set-key '(#\O) '(com-insert-charcode 212)) +(dead-circumflex-set-key '(#\U) '(com-insert-charcode 219)) +(dead-circumflex-set-key '(#\a) '(com-insert-charcode 226)) +(dead-circumflex-set-key '(#\e) '(com-insert-charcode 234)) +(dead-circumflex-set-key '(#\i) '(com-insert-charcode 238)) +(dead-circumflex-set-key '(#\o) '(com-insert-charcode 244)) +(dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) +(dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

1 0