Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31712

Modified Files: base.lisp gui.lisp packages.lisp Log Message: replaced *previous-command* and *goal-column* by slots in the pane according to a suggestion by Rudi Schlatte.

implemented dynamic abbrev expansion according to a suggestion by Luigi Panzeri.

Date: Fri Jan 7 08:26:25 2005 Author: rstrandh

Index: climacs/base.lisp diff -u climacs/base.lisp:1.11 climacs/base.lisp:1.12 --- climacs/base.lisp:1.11 Thu Jan 6 17:38:54 2005 +++ climacs/base.lisp Fri Jan 7 08:26:23 2005 @@ -137,6 +137,15 @@ while (constituentp (object-before mark)) do (delete-range mark -1)))

+(defun previous-word (mark) + "Return a freshly allocated sequence, that is word before the mark" + (region-to-sequence + (loop for i downfrom (offset mark) + while (and (plusp i) + (constituentp (buffer-object (buffer mark) (1- i)))) + finally (return i)) + mark)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Named objects @@ -195,4 +204,20 @@ (when offset (setf (offset mark) offset))))

+(defun buffer-search-word-backward (buffer offset word &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i downfrom (- offset (length word)) to 0 + when (and (or (zerop i) (whitespacep (buffer-object buffer (1- i)))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil)))

+(defun buffer-search-word-forward (buffer offset word &key (test #'eql)) + "Return the smallest offset of BUFFER >= (+ OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i upfrom (+ offset (length word)) to (- (size buffer) (max (length word) 1)) + when (and (whitespacep (buffer-object buffer (1- i))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil)))

Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.48 climacs/gui.lisp:1.49 --- climacs/gui.lisp:1.48 Thu Jan 6 17:41:11 2005 +++ climacs/gui.lisp Fri Jan 7 08:26:24 2005 @@ -36,7 +36,15 @@ ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) (point :initform nil :initarg :point :reader point) (syntax :initarg :syntax :accessor syntax) - (mark :initform nil :initarg :mark :reader mark))) + (mark :initform nil :initarg :mark :reader mark) + ;; allows a certain number of commands to have some minimal memory + (previous-command :initform nil :accessor previous-command) + ;; for next-line and previous-line commands + (goal-column :initform nil) + ;; for dynamic abbrev expansion + (original-prefix :initform nil) + (prefix-start-offset :initform nil) + (dabbrev-expansion-mark :initform nil)))

(defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) @@ -178,8 +186,6 @@ (t (unread-gesture gesture :stream stream) (values 1 nil)))))

-(defvar *previous-command*) - (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -209,9 +215,10 @@ (beep) (format *error-output* "~a~%" condition))) (setf gestures '()) - (setf *previous-command* (if (consp command) - (car command) - command)))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)))) (t nil))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) @@ -320,21 +327,21 @@ (insert-sequence point line) (insert-object point #\Newline))))

-(defvar *goal-column*) - (define-named-command com-previous-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (previous-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (previous-line point (slot-value win 'goal-column))))

(define-named-command com-next-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (next-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (next-line point (slot-value win 'goal-column))))

(define-named-command com-open-line () (open-line (point (win *application-frame*)))) @@ -596,6 +603,43 @@ :test (lambda (a b) (and (characterp b) (char-equal a b)))))

+(define-named-command com-dabbrev-expand () + (let* ((win (win *application-frame*)) + (point (point win))) + (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win + (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) + (setf (offset dabbrev-expansion-mark) + (offset point)) + (forward-word dabbrev-expansion-mark)) + ((mark< dabbrev-expansion-mark point) + (backward-object dabbrev-expansion-mark)) + (t (forward-object dabbrev-expansion-mark))))) + (unless (or (beginning-of-buffer-p point) + (not (constituentp (object-before point)))) + (unless (and (eq (previous-command win) 'com-dabbrev-expand) + (not (null prefix-start-offset))) + (setf dabbrev-expansion-mark (clone-mark point)) + (backward-word dabbrev-expansion-mark) + (setf prefix-start-offset (offset dabbrev-expansion-mark)) + (setf original-prefix (region-to-sequence prefix-start-offset point)) + (move)) + (loop until (or (end-of-buffer-p dabbrev-expansion-mark) + (and (or (beginning-of-buffer-p dabbrev-expansion-mark) + (not (constituentp (object-before dabbrev-expansion-mark)))) + (looking-at dabbrev-expansion-mark original-prefix))) + do (move)) + (if (end-of-buffer-p dabbrev-expansion-mark) + (progn (delete-region prefix-start-offset point) + (insert-sequence point original-prefix) + (setf prefix-start-offset nil)) + (progn (delete-region prefix-start-offset point) + (insert-sequence point + (let ((offset (offset dabbrev-expansion-mark))) + (prog2 (forward-word dabbrev-expansion-mark) + (region-to-sequence offset dabbrev-expansion-mark) + (setf (offset dabbrev-expansion-mark) offset)))) + (move)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global command table @@ -638,6 +682,7 @@ (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) +(global-set-key '(#/ :meta) 'com-dabbrev-expand)

(global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line)

Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.20 climacs/packages.lisp:1.21 --- climacs/packages.lisp:1.20 Wed Jan 5 06:09:04 2005 +++ climacs/packages.lisp Fri Jan 7 08:26:24 2005 @@ -52,7 +52,8 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward)) + #:search-forward #:search-backward + #:buffer-search-word-backward #:buffer-search-word-forward))

(defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base)