[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
Robert Strandh
rstrandh at common-lisp.net
Fri Jan 7 07:26:27 UTC 2005
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)
More information about the Climacs-cvs
mailing list