[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