[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp

Robert Strandh rstrandh at common-lisp.net
Wed Jan 5 05:09:08 UTC 2005


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) `(, at command-name :name t) `(,command-name :name t)) ,args , at 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)




More information about the Climacs-cvs mailing list