[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