1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20 (%include backquote)
21
22
23 (eval-when (compile eval)
24 (setsyntax '/# 'macro
25 '(lambda ()
26 (cond ((= (tyipeek) 57)
27 (tyi)
28 (tyi))
29 ((= (tyipeek) 136)
30 (tyi)
31 (- (boole 1 137 (tyi)) 100)))))
32 )
33
34 (defun chars-left-in-line macro (x)
35 `(- curlinel curpointpos 1))
36
37 (defun save-excursion-on-search-failure macro (x)
38 (let ((dummy (gensym))
39 (forms (cdr x))
40 (mark (gensym)))
41 `(let ((,dummy nil)
42 (,mark nil))
43 (unwind-protect
44 (progn
45 (setq ,mark (set-mark))
46 (setq ,dummy (progn . ,forms)))
47 (if ,mark
48 (if (null ,dummy) (go-to-mark ,mark))
49 (release-mark ,mark))))))
50
51 (%include e-macros)
52
53 (declare (special search-forward last-search-string search-string search-ring
54 search-from-end tty-no-upmotionp must-announce-search
55 last-char-was-^S isearch-stack macro-execution-in-progress
56 ITS-string-search-set-mark home-mark isearch-exit-char
57 MCS-editing-characters rubout-character)
58
59 (*expr minibuffer-rubout search:maybe-push-default
60 set-permanent-key mark-at-current-point-p
61 exch-point-mark forward-search-bounded go-to-line-point
62 reverse-search-bounded search:announce-partial-failure
63 search:last-string search:numeric-prompt search:prompt
64 search:rotate-ring)
65
66 (*lexpr gratuitous-mark-setter))
67
68
69
70
71
72
73 (defcom set-search-mode
74 &args ((search-type &symbol &prompt "Search mode: "
75 &completions '(string character ITS-string
76 its-string incremental regexp
77 regular-expression default)))
78 (cond ((memq search-type '(default string))
79 (set-permanent-key '^S 'string-search)
80 (set-permanent-key '^R 'reverse-string-search))
81 ((memq search-type '(character))
82 (set-permanent-key '^S 'character-search)
83 (set-permanent-key '^R 'reverse-character-search))
84 ((memq search-type '(ITS-string its-string))
85 (set-permanent-key '^S 'ITS-string-search)
86 (set-permanent-key '^R 'reverse-ITS-string-search))
87 ((memq search-type '(regular-expression regexp))
88 (set-permanent-key '^S 'regexp-search)
89 (set-permanent-key '^R 'reverse-regexp-search))
90 ((eq search-type 'incremental)
91 (set-permanent-key '^S 'incremental-search)
92 (set-permanent-key '^R 'reverse-incremental-search))
93 (t (display-error-noabort "Unknown search mode: " search-type)
94 (ring-tty-bell))))
95
96
97
98
99
100
101
102
103
104 (defcom character-search
105 (let ((search-forward t))
106 (character-search-)))
107
108
109
110 (defcom reverse-character-search
111 (let ((search-forward nil))
112 (character-search-)))
113
114
115
116 (defun character-search- ()
117 (with-mark home-mark
118 (let ((quoted nil))
119 (do-forever
120 (let ((ch (get-char)))
121 (cond ((and (= ch #^A) (not quoted))
122 (ITS-string-search-) (stop-doing))
123 ((and (= ch #^G) (not quoted))
124 (command-quit))
125 ((or (= ch #^J)
126 (and (= ch #^M) (not quoted)))
127 (search:maybe-push-default NL 'string)
128 (if search-forward
129 (if (lastlinep) (display-error "Search fails."))
130 (next-line)
131 else (if (firstlinep) (display-error "Search fails."))
132 (prev-line) (go-to-end-of-line))
133 (gratuitous-mark-setter home-mark)
134 (stop-doing))
135 ((and (= ch #^Q) (not quoted))
136 (setq quoted t))
137 ((and (= ch #^R) (not quoted))
138 (if search-forward
139 (setq search-forward (not search-forward))
140 else (and (search-for-default-string)
141 (gratuitous-mark-setter home-mark))
142 (stop-doing)))
143 ((and (= ch #^S) (not quoted))
144 (and (search-for-default-string)
145 (gratuitous-mark-setter home-mark))
146 (stop-doing))
147 ((and (= ch #^_) (not quoted))
148 (character-search-documentation))
149 (t
150 (let ((result nil))
151 (if search-forward (setq result (forward-search (ascii ch)))
152 else (setq result (reverse-search (ascii ch))))
153 (search:maybe-push-default (ascii ch) 'string)
154 (if result
155 (gratuitous-mark-setter home-mark)
156 (stop-doing)
157 else (display-error "Search fails."))))))))))
158
159
160
161 (defun search-for-default-string ()
162 (if (nullstringp last-search-string)
163 (display-error "No default search string.")
164 else (let ((result nil))
165 (if (> (stringlength last-search-string) 1)
166 (minibuffer-clear)
167 (minibuffer-print (cond (search-forward
168 "")
169 (t
170 "Reverse "))
171 "Search: " last-search-string))
172 (if search-forward (setq result (forward-search last-search-string))
173 else (setq result (reverse-search last-search-string)))
174 (or result (display-error "Search fails.")))))
175
176 (defun character-search-documentation ()
177 (init-local-displays)
178 (mapc 'local-display-generator-nnl
179 '("Character search options:" ""
180 "^S Search for default search string"
181 "^R If searching forward, reverse direction, otherwise"
182 " Search back for default string"
183 "^A ITS string search"
184 "CR, LF Search for next newline"
185 "^G Abort search"
186 "^Q Reads a character and searches for it"
187 "^_ Print this description"
188 "anything else"
189 " searches for the character"
190 "" "Type any character to remove this display."))
191 (end-local-displays)
192 (redisplay)
193 (get-char))
194
195
196
197
198
199
200
201
202
203
204 (defcom ITS-string-search
205 (let ((search-forward t))
206 (ITS-string-search-)))
207
208
209
210 (defcom reverse-ITS-string-search
211 (let ((search-forward nil))
212 (ITS-string-search-)))
213
214
215
216 (defun ITS-string-search- ()
217 (with-mark home-mark
218 (setq last-char-was-^S nil
219 search-string ""
220 search-from-end nil)
221 (ITS-string-search-announce)
222 (let ((ITS-string-search-set-mark nil)
223 (rubout-character (cadr MCS-editing-characters)))
224 (do-forever
225 (if (eq (ITS-string-search-process-char (get-char))
226 'done)
227 (stop-doing))))
228 (if (not macro-execution-in-progress)
229 (minibuffer-print-noclear " Done."))))
230
231
232
233 (defun ITS-string-search-announce ()
234 (if (not macro-execution-in-progress)
235 (minibuffer-clear)
236 (if search-forward
237 (if search-from-end
238 (minibuffer-print "BJ ITS String Search: ")
239 else (minibuffer-print "ITS String Search: "))
240 else
241 (if search-from-end
242 (minibuffer-print "ZJ Reverse ITS String Search: ")
243 else (minibuffer-print "Reverse ITS String Search: ")))
244 (minibuffer-print-noclear search-string))
245 (setq must-announce-search nil))
246
247
248
249 (defun ITS-string-search-process-char (ch)
250 (prog1
251 (cond
252 ((or (= ch 177) (= ch rubout-character))
253 (if (nullstringp search-string)
254 (ITS-string-search-quit)
255 else
256 (isearch-chop-string-and-minibuffer)
257 'continue))
258 ((= ch #^J) 'continue)
259 ((= ch #^G)
260 (ITS-string-search-quit))
261 ((= ch #^B)
262 (if search-forward
263 (setq search-from-end (not search-from-end))
264 (ITS-string-search-announce)
265 else
266 (ITS-string-search-error
267 "Can not search from beginning in reverse search."
268 nil))
269 'continue)
270 ((= ch #^E)
271 (if search-forward
272 (ITS-string-search-error
273 "Can not search from end in forward search."
274 nil)
275 else
276 (setq search-from-end (not search-from-end))
277 (ITS-string-search-announce))
278 'continue)
279 ((= ch #^L)
280 (if (not macro-execution-in-progress)
281 (minibuffer-clear)
282 (redisplay))
283 (ITS-string-search-announce)
284 'continue)
285 ((= ch #^Y)
286 (if (nullstringp last-search-string)
287 (ITS-string-search-error "No default search string." nil)
288 else
289 (setq search-string
290 (catenate search-string last-search-string))
291 (ITS-string-search-out last-search-string))
292 'continue)
293 ((= ch #^D)
294 (if (nullstringp last-search-string)
295 (ITS-string-search-error "No default search string." nil)
296 else
297 (setq search-string (search:rotate-ring))
298 (setq last-search-string (search:last-string))
299 (ITS-string-search-announce))
300 'continue)
301 ((= ch #^Q)
302 (let ((ch1 (ascii (get-char))))
303 (setq search-string (catenate search-string ch1))
304 (ITS-string-search-out ch1))
305 'continue)
306 ((= ch #^R)
307 (setq search-forward (not search-forward))
308 (ITS-string-search-announce)
309 'continue)
310 ((or (= ch #^S) (= ch #^[))
311 (if (and (= ch #^[) last-char-was-^S)
312 'done
313 else
314 (if (nullstringp search-string)
315 (setq search-string last-search-string)
316 (ITS-string-search-out search-string))
317 (if (nullstringp search-string)
318 (ITS-string-search-error "No search string." (= ch #^[))
319 else
320 (with-mark
321 start-pos
322 (let ((result nil))
323 (if search-from-end
324 (if search-forward
325 (go-to-beginning-of-buffer)
326 else (go-to-end-of-buffer)))
327 (if search-forward
328 (setq result (forward-search search-string))
329 else
330 (setq result (reverse-search search-string)))
331 (if result
332 (if (not ITS-string-search-set-mark)
333 (setq ITS-string-search-set-mark t)
334 (gratuitous-mark-setter home-mark))
335 (or macro-execution-in-progress
336 (redisplay))
337 (if tty-no-upmotionp
338 (setq must-announce-search t))
339 else
340 (ITS-string-search-error "Search fails."
341 (= ch #^[))
342 (go-to-mark start-pos)))))
343 (search:maybe-push-default search-string 'string)
344 (if (= ch #^S) 'continue
345 else 'done)))
346 ((= ch #^_)
347 (ITS-string-search-documentation)
348 'continue)
349 ((and (or (< ch 40) (> ch 177))
350 (not (or (= ch #^M) (= ch #^I))))
351 (ring-tty-bell)
352 'continue)
353 (t
354 (if (= ch #^M) (setq ch #^J))
355 (setq search-string
356 (catenate search-string (ascii ch)))
357 (ITS-string-search-out (ascii ch))))
358 (setq last-char-was-^S (= ch #^S))))
359
360
361 (defun ITS-string-search-out (string)
362 (if must-announce-search (ITS-string-search-announce)
363 else (or macro-execution-in-progress
364 (minibuffer-print-noclear string))))
365
366
367
368 (defun ITS-string-search-error (message use-minibuffer)
369 (if (or tty-no-upmotionp use-minibuffer)
370 (minibuffer-print message)
371 (setq must-announce-search t)
372 else
373 (init-local-displays)
374 (local-display-generator-nnl message)
375 (minibuffer-print-noclear ""))
376 (if macro-execution-in-progress (command-quit)
377 else (ring-tty-bell)))
378
379
380
381 (defun ITS-string-search-quit ()
382 (if (not macro-execution-in-progress)
383 (minibuffer-print-noclear " Done."))
384 (command-quit))
385
386 (defun ITS-string-search-documentation ()
387 (init-local-displays)
388 (mapc 'local-display-generator-nnl
389 `("ITS string search options:" ""
390 ,(catenate "DEL, "
391 (ItoC rubout-character)
392 " Remove last character from search string")
393 "ESC Exit search, possibly searching first if previous"
394 " character was not ^S"
395 "^S Search for next occurrence of search string or default"
396 "^R Reverse search direction"
397 "^B Toggle ""search from beginning of buffer"""
398 "^E Toggle ""search from end of buffer"""
399 "^Y Add default search string to search string"
400 "^D Rotate default search string ring, and makes it the"
401 " search string"
402 "CR Add newline to search string"
403 "^G Abort search and return to starting point"
404 "^Q Reads a character and adds it to search string"
405 "LF Nothing"
406 "^L Redisplay"
407 "^_ Print this description"
408 "printing characters, TAB, ^I"
409 " Adds to the search string, and searches"
410 "" "Type any character to remove this display."))
411 (end-local-displays)
412 (redisplay)
413 (get-char))
414
415
416
417
418
419
420
421
422 (defcom incremental-search
423 (let ((search-forward t))
424 (incremental-search-)))
425
426
427 (defcom reverse-incremental-search
428 (let ((search-forward nil))
429 (incremental-search-)))
430
431
432 (defun incremental-search- ()
433 (setq isearch-stack (list (cons nil (set-mark))))
434 (setq search-string "")
435 (incremental-search-announce)
436 (let ((isearch-exit-char nil)
437 (rubout-character (cadr MCS-editing-characters)))
438 (with-mark home-mark
439 (do-forever
440 (or macro-execution-in-progress (redisplay))
441 (if (eq (isearch-process-char (get-char)) 'done)
442 (stop-doing)))
443 (if (not (nullstringp search-string))
444 (gratuitous-mark-setter home-mark))
445 (search:maybe-push-default search-string 'string))
446 (mapc '(lambda (x)
447 (release-mark (cdr x)))
448 isearch-stack)
449 (if (not macro-execution-in-progress)
450 (minibuffer-print-noclear " Done.")
451 (redisplay))
452 (and isearch-exit-char
453 (process-char isearch-exit-char))))
454
455
456 (defun isearch-process-char (ch)
457 (cond ((or (= ch 177)
458 (= ch rubout-character))
459 (isearch-rubout))
460 ((= ch #^G)
461 (ring-tty-bell)
462 (setq search-string "")
463 (go-to-mark (cdar (last isearch-stack)))
464 'done)
465 ((= ch #^L)
466 (or macro-execution-in-progress (redisplay))
467 (incremental-search-announce)
468 'continue)
469 ((= ch #^Q)
470 (isearch-search-single (ascii (get-char))))
471 ((or (= ch #^S)(= ch #^R))
472 (let ((new-dir (= ch #^S)))
473 (if (not (eq new-dir search-forward))
474 (setq search-forward new-dir)
475 (or macro-execution-in-progress
476 (minibuffer-clear))
477 (incremental-search-announce)))
478 (if (not (nullstringp search-string))
479 (search:maybe-push-default search-string 'string)
480 (setq search-string "")
481 else
482 (or macro-execution-in-progress
483 (minibuffer-print-noclear last-search-string)))
484 (setq isearch-stack (cons (cons nil (set-mark))
485 isearch-stack))
486 (let ((nss (catenate search-string last-search-string)))
487 (if search-forward
488 (if (looking-at last-search-string)
489 (forward-search last-search-string)
490 (setq search-string nss)
491 'continue
492 else
493 (if (forward-search nss)
494 (setq search-string nss)
495 'continue
496 else
497 (or macro-execution-in-progress
498 (minibuffer-clear))
499 (incremental-search-failure)
500 (incremental-search-announce)))
501 else
502 (if (reverse-search nss)
503 (setq search-string nss)
504 'continue
505 else
506 (or macro-execution-in-progress
507 (minibuffer-clear))
508 (incremental-search-failure)
509 (incremental-search-announce)))))
510 ((= ch #^[)
511 'done)
512 ((= ch #^J) 'continue)
513 ((= ch #^M) (isearch-search-single NL))
514 ((= ch #^_) (incremental-search-documentation))
515 ((and (or (< ch 40) (> ch 177))
516 (not (= ch #^I)))
517 (setq isearch-exit-char ch)
518 'done)
519 (t
520 (isearch-search-single (ascii ch)))))
521
522
523
524 (defun isearch-rubout ()
525 (cond ((null (cdr isearch-stack))
526 (ring-tty-bell)
527 'done)
528 (t
529 (go-to-mark (cdar isearch-stack))
530 (release-mark (cdar isearch-stack))
531 (cond ((caar isearch-stack)
532 (isearch-chop-string-and-minibuffer)))
533 (setq isearch-stack (cdr isearch-stack))
534 'continue)))
535
536
537
538 (defun isearch-rubout ()
539 (cond ((null (cdr isearch-stack))
540 (ring-tty-bell)
541 'done)
542 (t
543 (go-to-mark (cdar isearch-stack))
544 (release-mark (cdar isearch-stack))
545 (cond ((caar isearch-stack)
546 (isearch-chop-string-and-minibuffer)))
547 (setq isearch-stack (cdr isearch-stack))
548 'continue)))
549
550 (declare (special display-ctlchar-with-^))
551
552 (defun isearch-chop-string-and-minibuffer ()
553 (let ((sl (stringlength search-string)))
554 (let ((lastch (CtoI (substr search-string sl 1))))
555 (setq search-string (substr search-string 1 (1- sl)))
556 (if (and (not tty-no-upmotionp)
557 (not macro-execution-in-progress))
558 (minibuffer-rubout
559 (cond ((and (> lastch 37) (< lastch 177))
560 1)
561 (display-ctlchar-with-^ 2)
562 (t 4)))))))
563
564
565 (defun isearch-search-single (ch)
566 (if (and (not tty-no-upmotionp)
567 (not macro-execution-in-progress))
568 (minibuffer-print-noclear ch))
569 (setq search-string (catenate search-string ch))
570 (setq isearch-stack (cons (cons 'insert (set-mark))
571 isearch-stack))
572 (if search-forward
573 (if-at ch
574 (forward-char)
575 'continue
576 else
577 (if (forward-search search-string)
578 'continue
579 else
580 (incremental-search-failure)
581 (isearch-rubout)))
582 else
583 (if (looking-at search-string)
584 'continue
585 else
586 (do-times (1- (stringlength search-string))
587 (forward-char))
588 (if (reverse-search search-string)
589 'continue
590 else
591 (do-times (1- (stringlength search-string))
592 (backward-char))
593 (incremental-search-failure)
594 (isearch-rubout)))))
595
596 (defun incremental-search-announce ()
597 (if (not macro-execution-in-progress)
598 (if search-forward (minibuffer-print "Incremental Search: ")
599 else (minibuffer-print "Reverse Incremental Search: "))
600 (minibuffer-print-noclear search-string))
601 'continue)
602
603 (defun incremental-search-failure ()
604 (if macro-execution-in-progress
605 (go-to-mark (cdar (last isearch-stack)))
606 (mapc '(lambda (x)
607 (release-mark (cdr x)))
608 isearch-stack)
609 (setq search-string "")
610 (search-failure-annunciator)
611 else
612 (ring-tty-bell)))
613
614 (defun incremental-search-documentation ()
615 (init-local-displays)
616 (mapc 'local-display-generator-nnl
617 `("Incremental search options:" ""
618 ,(catenate "DEL, "
619 (ItoC rubout-character)
620 " Undo last character")
621 "ESC Exit search"
622 "^S Search for next occurrence of search string or default"
623 "^R Reverse search for next occurrence"
624 "CR Add newline to search string"
625 "^G Abort search and return to starting point"
626 "^Q Reads a character, adds it to search string, and searches"
627 "LF Nothing"
628 "^L Redisplay"
629 "^_ Print this description"
630 "printing characters, TAB, ^I"
631 " Adds to the search string, and searches"
632 "other control characters"
633 " Ends search, executes as an Emacs command"
634 "" "Type any character to remove this display."))
635 (end-local-displays)
636 (redisplay)
637 (get-char))
638
639 ^L
640
641
642
643
644 (defcom global-regexp-print
645 &arguments ((string &string &default
646 &eval (regexp:prompt "Global regexp print")))
647 (setq string (regexp:compile-and-save string))
648 (let ((foundflag)
649 (tempmark))
650 (save-excursion
651 (go-to-beginning-of-buffer)
652 (do-forever
653 (setq tempmark (regexp:search string))
654 (if (not tempmark) (stop-doing))
655 (if (not foundflag)
656 (setq foundflag t)
657 (init-local-displays))
658 (if (not (mark-on-current-line-p tempmark))
659 (exch-point-mark tempmark)
660 (do-forever
661 (local-display-current-line)
662 (next-line)
663 (if (mark-on-current-line-p tempmark) (stop-doing))))
664 (release-mark tempmark)
665 (local-display-current-line)
666 (if (lastlinep) (stop-doing))
667 (next-line)))
668 (if foundflag (end-local-displays)
669 else (search-failure-annunciator))))
670 ^L
671
672
673
674
675
676
677
678 (defcom-synonym regexp-search-command regexp-search)
679
680 (defcom regexp-search
681 &cleanup regexp:command-cleanup
682 &prologue regexp:command-prologue
683 &epilogue regexp:command-epilogue
684 &inverse reverse-regexp-search
685 &negative-function reverse-regexp-search
686 &numeric-argument &repeat
687 &args ((regexp &default &eval (regexp:prompt "Regexp search")))
688 (setq regexp (regexp:compile-and-save regexp))
689 (save-excursion-on-search-failure
690 (regexp:search regexp)))
691
692
693 (defun regexp-search-in-line (regexp)
694 (setq regexp (regexp:compile-and-save regexp))
695 (save-excursion-on-search-failure
696 (regexp:match regexp (chars-left-in-line) nil)))
697
698
699 (defcom reverse-regexp-search
700 &cleanup regexp:command-cleanup
701 &prologue regexp:command-prologue
702 &epilogue regexp:command-epilogue
703 &inverse regexp-search
704 &negative-function regexp-search
705 &numeric-argument &repeat
706 &args ((regexp &default &eval (regexp:prompt "Reverse regexp search")))
707 (setq regexp (regexp:reverse (regexp:compile-and-save regexp)))
708 (save-excursion-on-search-failure
709 (regexp:reverse-search regexp)))
710
711
712 (defun reverse-regexp-search-in-line (regexp)
713 (setq regexp (regexp:reverse (regexp:compile-and-save regexp)))
714 (save-excursion-on-search-failure
715 (regexp:reverse-match regexp curpointpos nil)))
716 ^L
717 (defun regexp:command-prologue ()
718 (list (or numarg 1) 0 (set-mark)))
719
720
721 (defun regexp:command-cleanup (prologue-info)
722 (if prologue-info
723 (if (cdddr prologue-info)
724 (release-mark (cdddr prologue-info)))
725 (if (caddr prologue-info)
726 (go-to-mark (caddr prologue-info))
727 (release-mark (caddr prologue-info)))))
728
729
730 (defun regexp:command-epilogue (prologue-info result last-time)
731 (cond (result
732 (rplaca (cdr prologue-info) (1+ (cadr prologue-info)))
733 (and (cdddr prologue-info)
734 (release-mark (cdddr prologue-info)))
735 (or last-time
736 (rplacd (cddr prologue-info) result)))
737 ((null (cdddr prologue-info))
738 (search-failure-annunciator))
739 (t (setq result (cdddr prologue-info)
740 last-time t)
741 (save-excursion
742 (go-to-mark (caddr prologue-info))
743 (set-the-mark))))
744 (if last-time
745 (exch-point-mark result)
746 (set-the-mark)
747 (exch-point-mark result)
748 (release-mark result)
749 (release-mark (caddr prologue-info))
750 (rplaca (cddr prologue-info) nil)
751 (if (< (cadr prologue-info) (car prologue-info))
752 (search:announce-partial-failure (cadr prologue-info)))))
753
754
755 (defun regexp:prompt (prompt)
756 (setq prompt (search:prompt (search:numeric-prompt prompt)))
757 (regexp:compile-and-save prompt)
758 (search:maybe-push-default prompt 'regexp))
759 ^L
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784 (defvar regexp:saved-compiled-string nil)
785
786 (defun regexp:compile-and-save (regexp)
787 (cond ((nullstringp regexp)
788 (if regexp:saved-compiled-string regexp:saved-compiled-string
789 else (display-error "No saved regular expression.")))
790 ((samepnamep regexp (caar regexp:saved-compiled-string))
791 regexp:saved-compiled-string)
792 (t (setq regexp:saved-compiled-string (regexp:compile regexp)))))
793
794
795 (defun regexp:reverse (regexp)
796 (cond ((cdar regexp) (car regexp))
797 ((null (cdr regexp)) (car regexp))
798 ((< (length (cdr regexp)) 2)
799 (rplacd (car regexp) (cdr regexp)))
800 (t (rplacd (car regexp) (reverse (cdr regexp))))))
801 ^L
802
803
804
805
806
807 (defun regexp-emit macro (x)
808 (let ((tag (cadr x))
809 (value (caddr x)))
810 `(rplacd compiled-regexp (cons (cons ,tag ,value)
811 (cdr compiled-regexp)))))
812
813
814 (defun regexp-emit-constant macro (x)
815 (let ((delimiter (cadr x)))
816 `(cond ((null constant-begins))
817 ((eq constant-begins ,delimiter)
818 (setq constant-begins nil))
819 (t (do ((cursor constant-begins (cdr cursor)))
820 ((eq (cdr cursor) ,delimiter)
821 (rplacd cursor nil)))
822 (regexp-emit 'constant (maknam constant-begins))
823 (setq constant-begins nil)))))
824
825
826 (defun regexp-emit-dots macro (x)
827 (let ((delimiter (cadr x)))
828 `(cond ((null dots-begin))
829 ((eq dots-begin ,delimiter)
830 (setq dots-begin nil))
831 (t (do ((count 1 (1+ count))
832 (cursor dots-begin (cdr cursor)))
833 ((eq (cdr cursor) ,delimiter)
834 (regexp-emit 'dots count)))
835 (setq dots-begin nil)))))
836
837
838 (defun regexp-mark-constant macro (x)
839 `(progn
840 (regexp-emit-dots this-one)
841 (if (null constant-begins) (setq constant-begins this-one))))
842 ^L
843 (defun regexp:compile (regexp-string)
844 (let ((regexp-list (exploden regexp-string))
845 (compiled-regexp (list (list regexp-string))))
846 (if (= (car regexp-list) #/^)
847 (regexp-emit 'begins-line nil)
848 (setq regexp-list (cdr regexp-list)))
849 (do ((backslash-at 'backslash-at)
850 (ch (car regexp-list) (cadr this-one))
851 (constant-begins)
852 (dots-begin)
853 (escape)
854 (escape-patch)
855 (last-one nil this-one)
856 (star-at)
857 (this-one regexp-list (cdr this-one)))
858 ((null this-one)
859 (if escape
860 (display-error
861 "Invalid use of ""\c"" at end of regular expression."))
862 (regexp-emit-constant nil)
863 (regexp-emit-dots nil)
864 (rplacd compiled-regexp (nreverse (cdr compiled-regexp))))
865 (cond (escape
866 (setq escape nil)
867 (regexp-mark-constant))
868 ((= ch #/\)
869 (setq backslash-at this-one
870 escape-patch last-one)
871 (regexp-mark-constant))
872 ((and (= ch #/c) (eq backslash-at last-one))
873 (setq escape t)
874 (if (eq constant-begins backslash-at)
875 (setq constant-begins nil)
876 else (rplacd escape-patch (cdr this-one))))
877 ((= ch #/.)
878 (regexp-emit-constant this-one)
879 (if (null dots-begin) (setq dots-begin this-one))
880 (rplaca this-one nil))
881 ((= ch #/*)
882 (if (eq last-one star-at)
883 (display-error
884 "Invalid use of ""*"" in regular expression."))
885 (regexp-emit-constant last-one)
886 (regexp-emit-dots last-one)
887 (regexp-emit 'star (and (car last-one)
888 (ascii (car last-one))))
889 (setq star-at this-one))
890 ((and (= ch #/$) (null (cdr this-one)))
891 (regexp-emit-constant this-one)
892 (regexp-emit-dots this-one)
893 (regexp-emit 'ends-line nil))
894 (t (regexp-mark-constant))))))
895 ^L
896
897
898
899
900
901
902
903
904
905
906
907 (declare (special curline curstuff))
908
909 (defun regexp-constant-floating macro (x)
910 `(do ((backup (1- (stringlength (cdar regexp))))
911 (mark)
912 (string (cdar regexp)))
913 ((not (forward-search string)) nil)
914 (setq mark (regexp:match regexp 0 nil))
915 (if mark
916 (exch-point-mark mark)
917 (do-times (1+ backup) (backward-char))
918 (exch-point-mark mark)
919 (return mark))
920 (do-times backup (backward-char))))
921
922
923 (defun reverse-regexp-constant-floating macro (x)
924 `(do ((backup (1- (stringlength (cdar reverse-regexp))))
925 (mark)
926 (string (cdar reverse-regexp)))
927 ((not (reverse-search string)) nil)
928 (setq mark (regexp:reverse-match reverse-regexp 0 nil))
929 (if mark
930 (exch-point-mark mark)
931 (do-times (1+ backup) (forward-char))
932 (exch-point-mark mark)
933 (return mark))
934 (do-times backup (forward-char))))
935 ^L
936 (defun regexp-constant-within-balance macro (x)
937 `(do ((backup (1- (stringlength (cdar regexp))))
938 (cl curline)
939 (count)
940 (cpp curpointpos)
941 (mark)
942 (string (cdar regexp)))
943 ((not (setq count (forward-search-bounded string balance)))
944 (go-to-line-point cl cpp)
945 nil)
946 (setq mark (regexp:match regexp 0 nil))
947 (if mark
948 (exch-point-mark mark)
949 (do-times (1+ backup) (backward-char))
950 (exch-point-mark mark)
951 (return mark))
952 (setq balance (- balance count 1))
953 (do-times backup (backward-char))))
954
955
956 (defun reverse-regexp-constant-within-balance macro (x)
957 `(do ((backup (1- (stringlength (cdar reverse-regexp))))
958 (cl curline)
959 (count)
960 (cpp curpointpos)
961 (mark)
962 (string (cdar reverse-regexp)))
963 ((not (setq count (reverse-search-bounded string balance)))
964 (go-to-line-point cl cpp)
965 nil)
966 (setq mark (regexp:reverse-match reverse-regexp 0 nil))
967 (if mark
968 (exch-point-mark mark)
969 (do-times (1+ backup) (forward-char))
970 (exch-point-mark mark)
971 (return mark))
972 (setq balance (- balance count 1))
973 (do-times backup (forward-char))))
974 ^L
975 (defun regexp-dots-floating macro (x)
976 `(do ((count (cdar regexp))
977 (result))
978 ((or (if (not (> count (chars-left-in-line)))
979 (setq curpointpos (+ curpointpos count))
980 (setq result
981 (regexp:match regexp (chars-left-in-line) nil)))
982 (lastlinep))
983 result)
984 (next-line)))
985
986
987 (defun reverse-regexp-dots-floating macro (x)
988 `(do ((count (cdar reverse-regexp))
989 (result))
990 ((or (if (not (> count curpointpos))
991 (setq curpointpos (- curpointpos count))
992 (setq result (regexp:reverse-match reverse-regexp
993 curpointpos nil)))
994 (firstlinep))
995 result)
996 (prev-line)))
997 ^L
998 (defun regexp-dots-anchored macro (x)
999 `(let ((count (cdar regexp)))
1000 (if (not (> count (chars-left-in-line)))
1001 (let ((cl curline)
1002 (cpp curpointpos)
1003 (result))
1004 (if (> count balance) (setq balance 0 star-mark nil)
1005 else (setq balance (- balance count)))
1006 (setq curpointpos (+ curpointpos count))
1007 (setq result (regexp:match regexp balance star-mark))
1008 (cond (result (exch-point-mark result)
1009 (setq curpointpos cpp)
1010 (exch-point-mark result))
1011 (t (go-to-line-point cl cpp)))
1012 result))))
1013
1014
1015 (defun reverse-regexp-dots-anchored macro (x)
1016 `(let ((count (cdar reverse-regexp)))
1017 (if (not (> count curpointpos))
1018 (let ((cl curline)
1019 (cpp curpointpos)
1020 (result))
1021 (if (> count balance) (setq balance 0 star-mark nil)
1022 else (setq balance (- balance count)))
1023 (setq curpointpos (- curpointpos count))
1024 (setq result (regexp:reverse-match
1025 reverse-regexp balance star-mark))
1026 (cond (result (exch-point-mark result)
1027 (setq curpointpos cpp)
1028 (exch-point-mark result))
1029 (t (go-to-line-point cl cpp)))
1030 result))))
1031 ^L
1032 (defun regexp-star-floating macro (x)
1033 `(let ((char (cadr regexp))
1034 (cl curline)
1035 (cpp curpointpos)
1036 (result (regexp:search regexp)))
1037 (if result
1038 (exch-point-mark result)
1039 (cond (char
1040 (do ()
1041 ((and (eq cl curline) (= cpp curpointpos)))
1042 (or (eq char (curchar))
1043 (return nil))
1044 (forward-char)))
1045 ((eq cl curline)
1046 (go-to-line-point cl cpp))
1047 (t (go-to-beginning-of-line)))
1048 (exch-point-mark result)
1049 result))))
1050
1051
1052 (defun reverse-regexp-star-floating macro (x)
1053 `(let ((char (cadr reverse-regexp))
1054 (cl curline)
1055 (cpp curpointpos)
1056 (result (regexp:reverse-search reverse-regexp)))
1057 (if result
1058 (exch-point-mark result)
1059 (cond (char
1060 (do ()
1061 ((and (eq cl curline) (= cpp curpointpos)))
1062 (or (eq char (lefthand-char))
1063 (return nil))
1064 (backward-char)))
1065 ((eq cl curline)
1066 (go-to-line-point cl cpp))
1067 (t (go-to-end-of-line)))
1068 (exch-point-mark result)
1069 result))))
1070 ^L
1071 (defun regexp-star-anchored macro (x)
1072 `(let ((char (cdar regexp))
1073 (cl curline)
1074 (cpp curpointpos)
1075 (my-mark)
1076 (result))
1077 (cond (star-mark (setq my-mark star-mark)
1078 (exch-point-mark my-mark))
1079 (t (setq my-mark (set-mark))))
1080 (cond (char
1081 (do ()
1082 ((not (eq char (curchar))))
1083 (forward-char)
1084 (setq balance (1+ balance))))
1085 (t (setq balance (+ balance (chars-left-in-line)))
1086 (go-to-end-of-line)))
1087 (exch-point-mark my-mark)
1088 (setq result (regexp:match regexp balance my-mark))
1089 (or star-mark (release-mark my-mark))
1090 (cond (result (exch-point-mark result)
1091 (go-to-line-point cl cpp)
1092 (exch-point-mark result)))
1093 result))
1094
1095
1096 (defun reverse-regexp-star-anchored macro (x)
1097 `(let ((char (cdar reverse-regexp))
1098 (cl curline)
1099 (cpp curpointpos)
1100 (my-mark)
1101 (result))
1102 (cond (star-mark (setq my-mark star-mark)
1103 (exch-point-mark my-mark))
1104 (t (setq my-mark (set-mark))))
1105 (cond (char
1106 (do ()
1107 ((not (eq char (lefthand-char))))
1108 (backward-char)
1109 (setq balance (1+ balance))))
1110 (t (setq balance (+ balance curpointpos))
1111 (go-to-beginning-of-line)))
1112 (exch-point-mark my-mark)
1113 (setq result (regexp:reverse-match reverse-regexp
1114 balance my-mark))
1115 (or star-mark (release-mark my-mark))
1116 (cond (result (exch-point-mark result)
1117 (go-to-line-point cl cpp)
1118 (exch-point-mark result)))
1119 result))
1120 ^L
1121
1122
1123
1124
1125 (defun regexp:search (regexp)
1126 (setq regexp (cdr regexp))
1127 (cond ((null regexp) (set-mark))
1128 ((eq (caar regexp) 'constant)
1129 (regexp-constant-floating))
1130 ((eq (caar regexp) 'dots)
1131 (regexp-dots-floating))
1132 ((eq (caar regexp) 'star)
1133 (regexp-star-floating))
1134 ((eq (caar regexp) 'ends-line)
1135 (go-to-end-of-line)
1136 (set-mark))
1137
1138
1139
1140 ((and (lastlinep) (not (bolp))) nil)
1141 (t (if (not (bolp)) (next-line))
1142 (do ((result))
1143 ((or (setq result (regexp:match regexp 0 nil))
1144 (lastlinep))
1145 result)
1146 (next-line)))))
1147
1148
1149 (defun regexp:match (regexp balance star-mark)
1150 (setq regexp (cdr regexp))
1151 (cond ((null regexp)
1152 (prog1 (set-mark)
1153 (if star-mark (go-to-mark star-mark))))
1154 ((eq (caar regexp) 'constant)
1155 (regexp-constant-within-balance))
1156 ((eq (caar regexp) 'dots)
1157 (regexp-dots-anchored))
1158 ((eq (caar regexp) 'star)
1159 (regexp-star-anchored))
1160 ((eq (caar regexp) 'ends-line)
1161 (cond ((< balance (chars-left-in-line)) nil)
1162 (t (prog1 (set-mark)
1163 (go-to-end-of-line)))))
1164 ((bolp)
1165 (regexp:match regexp 0 nil))))
1166 ^L
1167
1168
1169
1170
1171
1172
1173 (defun regexp:reverse-search (reverse-regexp)
1174 (setq reverse-regexp (cdr reverse-regexp))
1175 (cond ((null reverse-regexp) (set-mark))
1176 ((eq (caar reverse-regexp) 'constant)
1177 (reverse-regexp-constant-floating))
1178 ((eq (caar reverse-regexp) 'dots)
1179 (reverse-regexp-dots-floating))
1180 ((eq (caar reverse-regexp) 'star)
1181 (reverse-regexp-star-floating))
1182 ((eq (caar reverse-regexp) 'begins-line)
1183 (go-to-beginning-of-line)
1184 (set-mark))
1185
1186
1187
1188 ((and (firstlinep) (not (eolp))) nil)
1189 (t (if (not (eolp)) (prev-line) (go-to-end-of-line))
1190 (do ((result))
1191 ((or (setq result
1192 (regexp:reverse-match reverse-regexp 0 nil))
1193 (firstlinep))
1194 result)
1195 (prev-line) (go-to-end-of-line)))))
1196
1197
1198 (defun regexp:reverse-match (reverse-regexp balance star-mark)
1199 (setq reverse-regexp (cdr reverse-regexp))
1200 (cond ((null reverse-regexp)
1201 (prog1 (set-mark)
1202 (if star-mark (go-to-mark star-mark))))
1203 ((eq (caar reverse-regexp) 'constant)
1204 (reverse-regexp-constant-within-balance))
1205 ((eq (caar reverse-regexp) 'dots)
1206 (reverse-regexp-dots-anchored))
1207 ((eq (caar reverse-regexp) 'star)
1208 (reverse-regexp-star-anchored))
1209 ((eq (caar reverse-regexp) 'begins-line)
1210 (cond ((> balance curpointpos) nil)
1211 (t (prog1 (set-mark)
1212 (go-to-beginning-of-line)))))
1213 ((eolp)
1214 (regexp:reverse-match reverse-regexp 0 nil))))