source: trunk/source/cocoa-ide/hemlock/src/search1.lisp @ 8774

Last change on this file since 8774 was 8774, checked in by gz, 12 years ago

fix compiler warnings

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.8 KB
Line 
1;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Searching and replacing functions for Hemlock.
13;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan.
14;;;
15
16(in-package :hemlock-internals)
17
18
19;;; The search pattern structure is used only by simple searches, more
20;;; complex ones make structures which include it.
21
22(defstruct (search-pattern (:print-function %print-search-pattern)
23                           (:constructor internal-make-search-pattern))
24  kind                        ; The kind of pattern to search for.
25  direction                   ; The direction to search in.
26  pattern                     ; The search pattern to use.
27  search-function             ; The function to call to search.
28  reclaim-function)           ; The function to call to reclaim this pattern.
29
30(setf (documentation 'search-pattern-p 'function)
31  "Returns true if its argument is a Hemlock search-pattern object,
32  Nil otherwise.")
33
34(defun %print-search-pattern (object stream depth)
35  (let ((*print-level* (and *print-level* (- *print-level* depth)))
36        (*print-case* :downcase))
37    (declare (special *print-level* *print-case*))
38    (write-string "#<Hemlock " stream)
39    (princ (search-pattern-direction object) stream)
40    (write-char #\space stream)
41    (princ (search-pattern-kind object) stream)
42    (write-string " Search-Pattern for ")
43    (prin1 (search-pattern-pattern object) stream)
44    (write-char #\> stream)
45    (terpri stream)))
46
47(defvar *search-pattern-experts* (make-hash-table :test #'eq)
48  "Holds an eq hashtable which associates search kinds with the functions
49  that know how to make patterns of that kind.")
50(defvar *search-pattern-documentation* ()
51  "A list of all the kinds of search-pattern that are defined.")
52
53;;; define-search-kind  --  Internal
54;;;
55;;;    This macro is used to define a new kind of search pattern.  Kind
56;;; is the kind of search pattern to define.  Lambda-list is the argument
57;;; list for the expert-function to be built and forms it's body.
58;;; The arguments passed are the direction, the pattern, and either
59;;; an old search-pattern of the same type or nil.  Documentation
60;;; is put on the search-pattern-documentation property of the kind
61;;; keyword.
62;;;
63(defmacro define-search-kind (kind lambda-list documentation &body forms)
64  (let ((dummy #-CLISP (gensym) #+CLISP (gentemp (format nil ".search-kind.~A" kind))))
65    `(progn
66      (push ,documentation *search-pattern-documentation*)
67      (defun ,dummy ()
68        (setf (gethash ,kind *search-pattern-experts*)
69              #'(lambda ,lambda-list ,@forms)))
70      (,dummy))))
71
72;;; new-search-pattern  --  Public
73;;;
74;;;    This function deallocates any old search-pattern and then dispatches
75;;; to the correct expert.
76;;;
77(defun new-search-pattern (kind direction pattern &optional
78                                result-search-pattern)
79  "Makes a new Hemlock search pattern of kind Kind to search direction
80  using Pattern.  Direction is either :backward or :forward.
81  If supplied, result-search-pattern is a pattern to destroy to make
82  the new one.  The variable *search-pattern-documentation* contains
83  documentation for each kind."
84  (unless (or (eq direction :forward) (eq direction :backward))
85    (error "~S is not a legal search direction." direction))
86  (when result-search-pattern
87    (funcall (search-pattern-reclaim-function result-search-pattern)
88             result-search-pattern)
89    (unless (eq kind (search-pattern-kind result-search-pattern))
90      (setq result-search-pattern nil)))
91  (let ((expert (gethash kind *search-pattern-experts*)))
92    (unless expert
93      (error "~S is not a defined search pattern kind." kind))
94    (funcall expert direction pattern result-search-pattern)))
95
96;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit
97;;;; in length.
98
99(defvar *spare-search-vectors* ())
100(eval-when (:compile-toplevel :execute)
101(defmacro new-search-vector ()
102  `(if *spare-search-vectors*
103       (pop *spare-search-vectors*)
104       (make-array search-char-code-limit)))
105
106(defmacro dispose-search-vector (vec)
107  `(push ,vec *spare-search-vectors*))
108); eval-when (:compile-toplevel :execute)
109
110;;;; macros used by various search kinds:
111
112;;; search-once-forward-macro  --  Internal
113;;;
114;;;    Passes search-fun strings, starts and lengths to do a forward
115;;; search.  The other-args are passed through to the searching
116;;; function after after everything else  The search-fun is
117;;; expected to return NIL if nothing is found, or it index where the
118;;; match ocurred.  Something non-nil is returned if something is
119;;; found and line and start are set to where it was found.
120;;;
121(defmacro search-once-forward-macro (line start search-fun &rest other-args)
122  `(do* ((l ,line)
123         (chars (line-chars l) (line-chars l))
124         (len (length chars) (length chars))
125         (start-pos ,start 0)
126         (index 0))
127        (())
128     (declare (simple-string chars) (fixnum start-pos len)
129              (type (or fixnum null) index))
130     (setq index (,search-fun chars start-pos len ,@other-args))
131     (when index
132       (setq ,start index  ,line l)
133       (return t))
134     (setq l (line-next l))
135     (when (null l) (return nil))))
136
137
138;;; search-once-backward-macro  --  Internal
139;;;
140;;;    Like search-once-forward-macro, except it goes backwards.  Length
141;;; is not passed to the search function, since it won't need it.
142;;;
143(defmacro search-once-backward-macro (line start search-fun &rest other-args)
144  `(do* ((l ,line)
145         (chars (line-chars l) (line-chars l))
146         (start-pos (1- ,start) (1- (length chars)))
147         (index 0))
148        (())
149     (declare (simple-string chars) (fixnum start-pos)
150              (type (or fixnum null) index))
151     (setq index (,search-fun chars start-pos ,@other-args))
152     (when index
153       (setq ,start index  ,line l)
154       (return t))
155     (setq l (line-previous l))
156     (when (null l) (return nil))))
157
158
159;;;; String Searches.
160;;;
161;;; We use the Boyer-Moore algorithm for string searches.
162;;;
163
164;;; sensitive-string-search-macro  --  Internal
165;;;
166;;;    This macro does a case-sensitive Boyer-Moore string search.
167;;;
168;;; Args:
169;;;    String - The string to search in.
170;;;    Start - The place to start searching at.
171;;;    Length - NIL if going backward, the length of String if going forward.
172;;;    Pattern - A simple-vector of characters.  A simple-vector is used
173;;; rather than a string because it is believed that simple-vector access
174;;; will be faster in most implementations.
175;;;    Patlen - The length of Pattern.
176;;;    Last - (1- Patlen)
177;;;    Jumps - The jump vector as given by compute-boyer-moore-jumps
178;;;    +/- - The function to increment with, either + (forward) or -
179;;; (backward)
180;;;    -/+ - Like +/-, only the other way around.
181(eval-when (:compile-toplevel :execute)
182(defmacro sensitive-string-search-macro (string start length pattern patlen
183                                                last jumps +/- -/+)
184  `(do ((scan (,+/- ,start ,last))
185        (patp ,last))
186       (,(if length `(>= scan ,length) '(minusp scan)))
187     (declare (fixnum scan patp))
188     (let ((char (schar ,string scan)))
189       (cond
190        ((char= char (svref ,pattern patp))
191         (if (zerop patp)
192             (return scan)
193             (setq scan (,-/+ scan 1)  patp (1- patp))))
194        (t
195         ;; If mismatch consult jump table to find amount to skip.
196         (let ((jump (svref ,jumps (search-char-code char))))
197           (declare (fixnum jump))
198           (if (> jump (- ,patlen patp))
199               (setq scan (,+/- scan jump))
200               (setq scan (,+/- scan (- ,patlen patp)))))
201         (setq patp ,last))))))
202
203;;; insensitive-string-search-macro  --  Internal
204;;;
205;;;    This macro is very similar to the case sensitive one, except that
206;;; we do the search for a hashed string, and then when we find a match
207;;; we compare the uppercased search string with the found string uppercased
208;;; and only say we win when they match too.
209;;;
210(defmacro insensitive-string-search-macro (string start length pattern
211                                                  folded-string patlen last
212                                                  jumps  +/- -/+)
213  `(do ((scan (,+/- ,start ,last))
214        (patp ,last))
215       (,(if length `(>= scan ,length) '(minusp scan)))
216     (declare (fixnum scan patp))
217     (let ((hash (search-hash-code (schar ,string scan))))
218       (declare (fixnum hash))
219       (cond
220        ((= hash (the fixnum (svref ,pattern patp)))
221         (if (zerop patp)
222             (if (do ((i ,last (1- i)))
223                     (())
224                   (when (char/=
225                          (search-char-upcase (schar ,string (,+/- scan i)))
226                          (schar ,folded-string i))
227                     (return nil))
228                   (when (zerop i) (return t)))
229                 (return scan)
230                 (setq scan (,+/- scan ,patlen)  patp ,last))
231             (setq scan (,-/+ scan 1)  patp (1- patp))))
232        (t
233         ;; If mismatch consult jump table to find amount to skip.
234         (let ((jump (svref ,jumps hash)))
235           (declare (fixnum jump))
236           (if (> jump (- ,patlen patp))
237               (setq scan (,+/- scan jump))
238               (setq scan (,+/- scan (- ,patlen patp)))))
239         (setq patp ,last))))))
240
241;;;; Searching for strings with newlines in them:
242;;;
243;;;    Due to the buffer representation, search-strings with embedded
244;;; newlines need to be special-cased.  What we do is break
245;;; the search string up into lines and then searching for a line with
246;;; the correct prefix.  This is actually a faster search.
247;;; For this one we just have one big hairy macro conditionalized for
248;;; both case-sensitivity and direction.  Have fun!!
249
250;;; newline-search-macro  --  Internal
251;;;
252;;;    Do a search for a string containing newlines.  Line is the line
253;;; to start on, and Start is the position to start at.  Pattern and
254;;; optionally Pattern2, are simple-vectors of things that represent
255;;; each line in the pattern, and are passed to Test-Fun.  Pattern
256;;; must contain simple-strings so we can take the length.  Test-Fun is a
257;;; thing to compare two strings and see if they are equal.  Forward-p
258;;; tells whether to go forward or backward.
259;;;
260(defmacro newline-search-macro (line start test-fun pattern forward-p
261                                     &optional pattern2)
262  `(let* ((patlen (length ,pattern))
263          (first (svref ,pattern 0))
264          (firstlen (length first))
265          (l ,line)
266          (chars (line-chars l))
267          (len (length chars))
268          ,@(if pattern2 `((other (svref ,pattern2 0)))))
269     (declare (simple-string first chars) (fixnum firstlen patlen len))
270     ,(if forward-p
271          ;; If doing a forward search, go to the next line if we could not
272          ;; match due to the start position.
273          `(when (< (- len ,start) firstlen)
274             (setq l (line-next l)))
275          ;; If doing a backward search, go to the previous line if the current
276          ;; line could not match the last line in the pattern, and then go
277          ;; back the 1- number of lines in the pattern to avoid a possible
278          ;; match across the starting point.
279          `(let ((1-len (1- patlen)))
280             (declare (fixnum 1-len))
281             (when (< ,start (length (the simple-string
282                                          (svref ,pattern 1-len))))
283               (setq l (line-previous l)))
284             (dotimes (i 1-len)
285               (when (null l) (return nil))
286               (setq l (line-previous l)))))
287     (do* ()
288          ((null l))
289       (setq chars (line-chars l)  len (length chars))
290       ;; If the end of this line is the first line in the pattern then check
291       ;; to see if the other lines match.
292       (when (and (>= len firstlen)
293                  (,test-fun chars first other
294                             :start1 (- len firstlen) :end1 len
295                             :end2 firstlen))
296         (when
297          (do ((m (line-next l) (line-next m))
298               (i 2 (1+ i))
299               (next (svref ,pattern 1) (svref ,pattern i))
300               ,@(if pattern2
301                     `((another (svref ,pattern2 1)
302                                (svref ,pattern2 i))))
303               (len 0)
304               (nextlen 0)
305               (chars ""))
306              ((null m))
307            (declare (simple-string next chars) (fixnum len nextlen i))
308            (setq chars (line-chars m)  nextlen (length next)
309                  len (length chars))
310            ;; When on last line of pattern, check if prefix of line.
311            (when (= i patlen)
312              (return (and (>= len nextlen)
313                           (,test-fun chars next another :end1 nextlen
314                                      :end2 nextlen))))
315            (unless (,test-fun chars next another :end1 len
316                               :end2 nextlen)
317              (return nil)))
318          (setq ,line l  ,start (- len firstlen))
319          (return t)))
320       ;; If not, try the next line
321       (setq l ,(if forward-p '(line-next l) '(line-previous l))))))
322
323;;;; String-comparison macros that are passed to newline-search-macro
324
325;;; case-sensitive-test-fun  --  Internal
326;;;
327;;;    Just thows away the extra arg and calls string=.
328;;;
329(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys)
330  (declare (ignore ignore))
331  `(string= ,string1 ,string2 ,@keys))
332
333;;; case-insensitive-test-fun  --  Internal
334;;;
335;;;    First compare the characters hashed with hashed-string2 and then
336;;; only if they agree do an actual compare with case-folding.
337;;;
338(defmacro case-insensitive-test-fun (string1 string2 hashed-string2
339                                             &key end1 (start1 0) end2)
340  `(when (= (- ,end1 ,start1) ,end2)
341     (do ((i 0 (1+ i)))
342         ((= i ,end2)
343          (dotimes (i ,end2 t)
344            (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i)))
345                          (schar ,string2 i))
346              (return nil))))
347       (when (/= (search-hash-code (schar ,string1 (+ ,start1 i)))
348                 (svref ,hashed-string2 i))
349         (return nil)))))
350); eval-when (:compile-toplevel :execute)
351
352;;; compute-boyer-moore-jumps  --  Internal
353;;;
354;;;    Compute return a jump-vector to do a Boyer-Moore search for
355;;; the "string" of things in Vector.  Access-fun is a function
356;;; that aref's vector and returns a number.
357;;;
358(defun compute-boyer-moore-jumps (vec access-fun)
359  (declare (simple-vector vec))
360  (let ((jumps (new-search-vector))
361        (len (length vec)))
362    (declare (simple-vector jumps))
363    (when (zerop len) (error "Zero length search string not allowed."))
364    ;; The default jump is the length of the search string.
365    (dotimes (i search-char-code-limit)
366      (setf (aref jumps i) len))
367    ;; For chars in the string the jump is the distance from the end.
368    (dotimes (i len)
369      (setf (aref jumps (funcall access-fun vec i)) (- len i 1)))
370    jumps))
371
372;;;; Case insensitive searches
373
374;;; In order to avoid case folding, we do a case-insensitive hash of
375;;; each character.  We then search for string in this translated
376;;; character set, and reject false successes by checking of the found
377;;; string is string-equal the the original search string.
378;;;
379
380(defstruct (string-insensitive-search-pattern
381            (:include search-pattern)
382            (:conc-name string-insensitive-)
383            (:print-function %print-search-pattern))
384  jumps
385  hashed-string
386  folded-string)
387
388;;;  Search-Hash-String  --  Internal
389;;;
390;;;    Return a simple-vector containing the search-hash-codes of the
391;;; characters in String.
392;;;
393(defun search-hash-string (string)
394  (declare (simple-string string))
395  (let* ((len (length string))
396         (result (make-array len)))
397    (declare (fixnum len) (simple-vector result))
398    (dotimes (i len result)
399      (setf (aref result i) (search-hash-code (schar string i))))))
400
401;;; make-insensitive-newline-pattern  -- Internal
402;;;
403;;;    Make bash in fields in a string-insensitive-search-pattern to
404;;; do a search for a string with newlines in it.
405;;;
406(defun make-insensitive-newline-pattern (pattern folded-string)
407  (declare (simple-string folded-string))
408  (let* ((len (length folded-string))
409         (num (1+ (count #\newline folded-string :end len)))
410         (hashed (make-array num))
411         (folded (make-array num)))
412    (declare (simple-vector hashed folded) (fixnum len num))
413    (do ((prev 0 nl)
414         (i 0 (1+ i))
415         (nl (position #\newline folded-string :end len)
416             (position #\newline folded-string :start nl  :end len)))
417        ((null nl)
418         (let ((piece (subseq folded-string prev len)))
419           (setf (aref folded i) piece)
420           (setf (aref hashed i) (search-hash-string piece))))
421      (let ((piece (subseq folded-string prev nl)))
422        (setf (aref folded i) piece)
423        (setf (aref hashed i) (search-hash-string piece)))
424      (incf nl))
425    (setf (string-insensitive-folded-string pattern) folded
426          (string-insensitive-hashed-string pattern) hashed)))
427
428
429(define-search-kind :string-insensitive (direction pattern old)
430  ":string-insensitive - Pattern is a string to do a case-insensitive
431  search for."
432  (unless old (setq old (make-string-insensitive-search-pattern)))
433  (setf (search-pattern-kind old) :string-insensitive
434        (search-pattern-direction old) direction
435        (search-pattern-pattern old) pattern)
436  (let* ((folded-string (string-upcase pattern)))
437    (declare (simple-string folded-string))
438    (cond
439     ((find #\newline folded-string)
440      (make-insensitive-newline-pattern old folded-string)
441      (setf (search-pattern-search-function old)
442            (if (eq direction :forward)
443                #'insensitive-find-newline-once-forward-method
444                #'insensitive-find-newline-once-backward-method))
445      (setf (search-pattern-reclaim-function old) #'identity))
446     (t
447      (case direction
448        (:forward
449         (setf (search-pattern-search-function old)
450               #'insensitive-find-string-once-forward-method))
451        (t
452         (setf (search-pattern-search-function old)
453               #'insensitive-find-string-once-backward-method)
454         (setq folded-string (nreverse folded-string))))
455      (let ((hashed-string (search-hash-string folded-string)))
456        (setf (string-insensitive-hashed-string old) hashed-string
457              (string-insensitive-folded-string old) folded-string)
458        (setf (string-insensitive-jumps old)
459              (compute-boyer-moore-jumps hashed-string #'svref))
460        (setf (search-pattern-reclaim-function old)
461              #'(lambda (p)
462                  (dispose-search-vector (string-insensitive-jumps p))))))))
463  old)
464
465(defun insensitive-find-string-once-forward-method (pattern line start)
466  (let* ((hashed-string (string-insensitive-hashed-string pattern))
467         (folded-string (string-insensitive-folded-string pattern))
468         (jumps (string-insensitive-jumps pattern))
469         (patlen (length hashed-string))
470         (last (1- patlen)))
471    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
472             (fixnum patlen last))
473    (when (search-once-forward-macro
474           line start insensitive-string-search-macro
475           hashed-string folded-string patlen last jumps + -)
476      (values line start patlen))))
477
478(defun insensitive-find-string-once-backward-method (pattern line start)
479  (let* ((hashed-string (string-insensitive-hashed-string pattern))
480         (folded-string (string-insensitive-folded-string pattern))
481         (jumps (string-insensitive-jumps pattern))
482         (patlen (length hashed-string))
483         (last (1- patlen)))
484    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
485             (fixnum patlen last))
486    (when (search-once-backward-macro
487           line start insensitive-string-search-macro
488           nil hashed-string folded-string patlen last jumps - +)
489      (values line (- start last) patlen))))
490
491(eval-when (:compile-toplevel :execute)
492(defmacro def-insensitive-newline-search-method (name direction)
493  `(defun ,name (pattern line start)
494     (let* ((hashed (string-insensitive-hashed-string pattern))
495            (folded-string (string-insensitive-folded-string pattern))
496            (patlen (length (the string (search-pattern-pattern pattern)))))
497       (declare (simple-vector hashed folded-string))
498       (when (newline-search-macro line start case-insensitive-test-fun
499                                   folded-string ,direction hashed)
500         (values line start patlen)))))
501); eval-when (:compile-toplevel :execute)
502
503(def-insensitive-newline-search-method
504  insensitive-find-newline-once-forward-method t)
505(def-insensitive-newline-search-method
506  insensitive-find-newline-once-backward-method nil)
507
508;;;; And Snore, case sensitive.
509;;;
510;;;    This is horribly repetitive, but if I introduce another level of
511;;; macroexpansion I will go Insaaaane....
512;;;
513(defstruct (string-sensitive-search-pattern
514            (:include search-pattern)
515            (:conc-name string-sensitive-)
516            (:print-function %print-search-pattern))
517  string
518  jumps)
519
520;;; make-sensitive-newline-pattern  -- Internal
521;;;
522;;;    The same, only more sensitive (it hurts when you do that...)
523;;;
524(defun make-sensitive-newline-pattern (pattern string)
525  (declare (simple-vector string))
526  (let* ((string (coerce string 'simple-string))
527         (len (length string))
528         (num (1+ (count #\newline string :end len)))
529         (sliced (make-array num)))
530    (declare (simple-string string) (simple-vector sliced) (fixnum len num))
531    (do ((prev 0 nl)
532         (i 0 (1+ i))
533         (nl (position #\newline string :end len)
534             (position #\newline string :start nl  :end len)))
535        ((null nl)
536         (setf (aref sliced i) (subseq string prev len)))
537      (setf (aref sliced i) (subseq string prev nl))
538      (incf nl))
539    (setf (string-sensitive-string pattern) sliced)))
540
541
542(define-search-kind :string-sensitive (direction pattern old)
543  ":string-sensitive - Pattern is a string to do a case-sensitive
544  search for."
545  (unless old (setq old (make-string-sensitive-search-pattern)))
546  (setf (search-pattern-kind old) :string-sensitive
547        (search-pattern-direction old) direction
548        (search-pattern-pattern old) pattern)
549  (let* ((string (coerce pattern 'simple-vector)))
550    (declare (simple-vector string))
551    (cond
552     ((find #\newline string)
553      (make-sensitive-newline-pattern old string)
554      (setf (search-pattern-search-function old)
555            (if (eq direction :forward)
556                #'sensitive-find-newline-once-forward-method
557                #'sensitive-find-newline-once-backward-method))
558      (setf (search-pattern-reclaim-function old) #'identity))
559     (t
560      (case direction
561        (:forward
562         (setf (search-pattern-search-function old)
563               #'sensitive-find-string-once-forward-method))
564        (t
565         (setf (search-pattern-search-function old)
566               #'sensitive-find-string-once-backward-method)
567         (setq string (nreverse string))))
568      (setf (string-sensitive-string old) string)
569      (setf (string-sensitive-jumps old)
570            (compute-boyer-moore-jumps
571             string #'(lambda (v i) (char-code (svref v i)))))
572      (setf (search-pattern-reclaim-function old)
573            #'(lambda (p)
574                (dispose-search-vector (string-sensitive-jumps p)))))))
575  old)
576
577
578(defun sensitive-find-string-once-forward-method (pattern line start)
579  (let* ((string (string-sensitive-string pattern))
580         (jumps (string-sensitive-jumps pattern))
581         (patlen (length string))
582         (last (1- patlen)))
583    (declare (simple-vector jumps string) (fixnum patlen last))
584    (when (search-once-forward-macro
585           line start sensitive-string-search-macro
586           string patlen last jumps + -)
587      (values line start patlen))))
588
589(defun sensitive-find-string-once-backward-method (pattern line start)
590  (let* ((string (string-sensitive-string pattern))
591         (jumps (string-sensitive-jumps pattern))
592         (patlen (length string))
593         (last (1- patlen)))
594    (declare (simple-vector jumps string) (fixnum patlen last))
595    (when (search-once-backward-macro
596           line start sensitive-string-search-macro
597           nil string patlen last jumps - +)
598      (values line (- start last) patlen))))
599
600(eval-when (:compile-toplevel :execute)
601(defmacro def-sensitive-newline-search-method (name direction)
602  `(defun ,name (pattern line start)
603     (let* ((string (string-sensitive-string pattern))
604            (patlen (length (the string (search-pattern-pattern pattern)))))
605       (declare (simple-vector string))
606       (when (newline-search-macro line start case-sensitive-test-fun
607                                   string ,direction)
608         (values line start patlen)))))
609); eval-when (:compile-toplevel :execute)
610
611(def-sensitive-newline-search-method
612  sensitive-find-newline-once-forward-method t)
613(def-sensitive-newline-search-method
614  sensitive-find-newline-once-backward-method nil)
615
616(defun find-pattern (mark search-pattern &optional stop-mark)
617  "Find a match of Search-Pattern starting at Mark.  Mark is moved to
618  point before the match and the number of characters matched is returned.
619  If there is no match for the pattern then Mark is not modified and NIL
620  is returned.
621  If stop-mark is specified, NIL is returned and mark is not moved if
622  the point before the match is after stop-mark"
623  (close-line)
624  (multiple-value-bind (line start matched)
625                       (funcall (search-pattern-search-function search-pattern)
626                                search-pattern (mark-line mark)
627                                (mark-charpos mark))
628    (when (and matched
629               (or (null stop-mark)
630                   (< (line-number line) (line-number (mark-line stop-mark)))
631                   (and (= (line-number line) (line-number (mark-line stop-mark)))
632                        (<= start (mark-charpos stop-mark)))))
633      (move-to-position mark start line)
634      matched)))
635
636;;; replace-pattern  --  Public
637;;;
638;;;
639(defun replace-pattern (mark search-pattern replacement &optional n)
640  "Replaces N occurrences of the Search-Pattern with the Replacement string
641  in the text starting at the given Mark.  If N is Nil, all occurrences
642  following the Mark are replaced."
643  (close-line)
644  (do* ((replacement (coerce replacement 'simple-string))
645        (new (length (the simple-string replacement)))
646        (fun (search-pattern-search-function search-pattern))
647        (forward-p (eq (search-pattern-direction search-pattern) :forward))
648        (n (if n (1- n) -1) (1- n))
649        (m (copy-mark mark :temporary)) line start matched)
650       (())
651    (multiple-value-setq (line start matched)
652      (funcall fun search-pattern (mark-line m) (mark-charpos m)))
653    (unless matched (return m))
654    (setf (mark-line m) line  (mark-charpos m) start)
655    (delete-characters m matched)
656    (insert-string m replacement)
657    (when forward-p (character-offset m new))
658    (when (zerop n) (return m))
659    (close-line)))
Note: See TracBrowser for help on using the repository browser.