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