1 ;;; ***********************************************************
   2 ;;; *                                                         *
   3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4 ;;; *                                                         *
   5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
   6 ;;; * Technology and Honeywell Information Systems, Inc.      *
   7 ;;; *                                                         *
   8 ;;; ***********************************************************
   9 ;;;
  10 ;;;
  11 ;;;       Various Hairy Search Commands
  12 ;;;        GMP
  13 ;;;       CR/NL handling 5/23/80 by BSG
  14 ;;;       Gratuitous marks 11/06/81 by Barmar
  15 ;;;       JSL's regular expressions and other stuff, 30 August 1982 Barmar
  16 ;;;       Added ^_ (self-documentation) response to searches,
  17 ;;;       and moved query-replace out to e_macops_. 31 August 1982 Barmar
  18 ;;;
  19 
  20 (%include backquote)
  21 
  22 ;;; read macro 12/3/78 by BSG
  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 );;;end of eval-when
  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 ;;; Command intended for use in start_up.emacs.  It sets permanent definitions
  70 ;;; of ^S and ^R to specified type of search.  Note that when an unrecognized
  71 ;;; type is supplied it merely prints an error without using command-quit.
  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 ;;; ^L
  96 
  97 ;;;
  98 ;;;       Character search commands (from ITS)
  99 ;;;        GMP, 08/31/78
 100 ;;;
 101 
 102 
 103 ;;; Character search command
 104 (defcom character-search
 105         (let ((search-forward t))
 106              (character-search-)))
 107 
 108 
 109 ;;; Reverse character search command
 110 (defcom reverse-character-search
 111         (let ((search-forward nil))
 112              (character-search-)))
 113 
 114 
 115 ;;; Subr that actually does character search
 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))     ; string search
 122                           (ITS-string-search-) (stop-doing))
 123                          ((and (= ch #^G) (not quoted))     ; punt
 124                           (command-quit))
 125                          ((or (= ch #^J)          ; find line break
 126                               (and (= ch #^M) (not quoted)))     ; ^M (unquoted), same as ^J
 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))     ; quote char
 136                           (setq quoted t))
 137                          ((and (= ch #^R) (not quoted))     ; reverse direction
 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))     ; look for default
 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                       ; look for this
 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 ;;; Search for current default string
 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 ;;; ^L
 195 
 196 ;;;
 197 ;;;       ITS String search commands
 198 ;;;        GMP, 08/31/78
 199 ;;;       Cleaned up and bugs fixed 1 July 1981 Barry Margolin
 200 ;;;       Merged and installed 1 July 1981 RMSoley
 201 ;;;
 202 
 203 ;;; ITS string search command
 204 (defcom ITS-string-search
 205         (let ((search-forward t))
 206              (ITS-string-search-)))
 207 
 208 
 209 ;;; Reverse ITS string search command
 210 (defcom reverse-ITS-string-search
 211         (let ((search-forward nil))
 212              (ITS-string-search-)))
 213 
 214 
 215 ;;; Subr to perform ITS string search
 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 ;;; Announce direction, type, and search string
 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 ;;; Handle single character of ITS string search
 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)   ; need better for printing
 257                 'continue))
 258            ((= ch #^J) 'continue)                 ;LF
 259            ((= ch #^G)
 260             (ITS-string-search-quit))             ; punt
 261            ((= ch #^B)                            ; complement search from beginning
 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)                            ; complement search from end
 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))            ; redisplay
 283             (ITS-string-search-announce)
 284             'continue)
 285            ((= ch #^Y)                            ; append default string
 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)                            ; yank default and rotate
 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)) ; copy of top
 299                 (ITS-string-search-announce))
 300             'continue)
 301            ((= ch #^Q)                            ; quote next chararacter
 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)                            ; reverse direction of search
 307             (setq search-forward (not search-forward))
 308             (ITS-string-search-announce)
 309             'continue)
 310            ((or (= ch #^S) (= ch #^[))            ; ^S or ESC, search and maybe quit
 311             (if (and (= ch #^[) last-char-was-^S) ; ESC after ^S, just exit
 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)     ;remember that we did it.
 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          ; keep looking
 345                     else 'done)))                 ; ESC, search terminates
 346            ((= ch #^_)
 347             (ITS-string-search-documentation)
 348             'continue)
 349            ((and (or (< ch 40) (> ch 177))        ; unknown control
 350                  (not (or (= ch #^M) (= ch #^I))))
 351             (ring-tty-bell)
 352             'continue)
 353            (t                                     ; normal character
 354              (if (= ch #^M) (setq ch #^J))        ;cr => nl 5/23/80
 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 ;;; Add string to minibuffer unless must redisplay minibuffer
 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 ;;; Print error for ITS string search
 368 (defun ITS-string-search-error (message use-minibuffer)
 369        (if (or tty-no-upmotionp use-minibuffer)
 370            (minibuffer-print message)             ; not display-error since not fatal
 371            (setq must-announce-search t)
 372            else                                   ; for display, print it
 373            (init-local-displays)
 374            (local-display-generator-nnl message)
 375            (minibuffer-print-noclear ""))         ; reposition cursor
 376        (if macro-execution-in-progress (command-quit)
 377            else (ring-tty-bell)))
 378 
 379 
 380 ;;; Exit ITS string search
 381 (defun ITS-string-search-quit ()
 382        (if (not macro-execution-in-progress)
 383            (minibuffer-print-noclear "   Done.")) ; If displaying, output message.
 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 ;;; ^L
 415 
 416 ;;;
 417 ;;;       Incremental Search
 418 ;;;
 419 
 420 
 421 ;;; Incremental search command
 422 (defcom incremental-search
 423         (let ((search-forward t))
 424              (incremental-search-)))
 425 
 426 ;;; Reverse Incremental search command
 427 (defcom reverse-incremental-search
 428         (let ((search-forward nil))
 429              (incremental-search-)))
 430 
 431 ;;;Subr to do all the work
 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))     ;if didn't abort search
 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 ;;; Process a single character
 456 (defun isearch-process-char (ch)
 457        (cond ((or (= ch 177)
 458                   (= ch rubout-character)) ;rubout last char
 459               (isearch-rubout))
 460              ((= ch #^G)                          ; abort search
 461               (ring-tty-bell)
 462               (setq search-string "")
 463               (go-to-mark (cdar (last isearch-stack)))
 464               'done)
 465              ((= ch #^L)                          ; redisplay
 466               (or macro-execution-in-progress (redisplay))
 467               (incremental-search-announce)
 468               'continue)
 469              ((= ch #^Q)                          ; quote next char
 470               (isearch-search-single (ascii (get-char))))
 471              ((or (= ch #^S)(= ch #^R))           ; search again or use default
 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))    ;non-inserting
 485                                         isearch-stack))
 486               (let ((nss (catenate search-string last-search-string)))
 487                    (if search-forward             ;Movin' right...
 488                        (if (looking-at last-search-string) ;already in front of it, OK
 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               ;not found again
 497                                (or macro-execution-in-progress
 498                                    (minibuffer-clear))
 499                                (incremental-search-failure)
 500                                (incremental-search-announce)))
 501                        else                       ;Movin' left...
 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 #^[)                          ; all done
 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))      ;random control char, exits
 516                    (not (= ch #^I)))              ;search, then gets executed
 517               (setq isearch-exit-char ch)
 518               'done)
 519              (t                                   ;normal char, search for it
 520                (isearch-search-single (ascii ch)))))
 521 
 522 
 523 ;;; Delete a character from search string
 524 (defun isearch-rubout ()
 525        (cond ((null (cdr isearch-stack))          ;nothing to rubout, abort
 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)        ;rubbing out self-insert
 532                       (isearch-chop-string-and-minibuffer)))
 533                (setq isearch-stack (cdr isearch-stack))
 534                'continue)))
 535 
 536 
 537 ;;; Delete a character from search string
 538 (defun isearch-rubout ()
 539        (cond ((null (cdr isearch-stack))          ;nothing to rubout, abort
 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)        ;rubbing out self-insert
 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)) ;printing char
 560                               1)
 561                              (display-ctlchar-with-^ 2)
 562                              (t 4)))))))          ;pretty kludgey, eh?
 563 
 564 ;;; Search for a single character incrementally
 565 (defun isearch-search-single (ch)
 566        (if (and (not tty-no-upmotionp)            ;put in buffer if needed
 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                              ;char is here, continue along
 574                   (forward-char)
 575                   'continue
 576                   else                            ;not here, search again
 577                   (if (forward-search search-string)
 578                       'continue                   ;found it
 579                       else                        ;not found, flush char typed
 580                       (incremental-search-failure)
 581                       (isearch-rubout)))
 582            else                                   ;Reverse Isearch
 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 ;;; Global Regular Expression Print
 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 ;;; These commands autoload from emacs-extended-searches
 672 
 673 ;;;
 674 ;;; Regular Expression searches in Lisp.
 675 ;;;  J. Spencer Love, 7 May 1982
 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)      ; For cleanup
 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 ;;; Translating regular expressions to list form.
 762 ;;;
 763 ;;; The format of a compiled regular expression is:
 764 ;;;
 765 ;;;   ((original-string . reversed-token-list) . token-list)
 766 ;;;
 767 ;;; The original-string is the argument given to compile-regexp.
 768 ;;; The reversed-token-list is initially nil, and is filled in
 769 ;;; by reverse-regexp, which returns the car of the compiled regexp.
 770 ;;;
 771 ;;; Each token in the token list is of the form:
 772 ;;;
 773 ;;;   (tag . value)
 774 ;;;
 775 ;;; CONSTRUCT       TAG                 VALUE
 776 ;;;   ^             begins-string       nil
 777 ;;;   $             ends-string         nil
 778 ;;;   string        constant            string from (maknam)
 779 ;;;   .*            star                nil
 780 ;;;   *             star                preceding char from (ascii)
 781 ;;;   .             dots                count of contiguous dots
 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 ;;; Here follow macros for lexically inserting code into compile-regexp,
 803 ;;; which follows them.  In some cases the macros are used in multiple
 804 ;;; places, but others are split out to make the code clearer and keep
 805 ;;; the indentation reasonable for 80 column screens.
 806 
 807 (defun regexp-emit macro (x)                      ; A conventional PUSH macro
 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)             ; Construct a constant string
 815        (let ((delimiter (cadr x)))                ; to be PUSHed, if present.
 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)                 ; Count the contiguous dots
 827        (let ((delimiter (cadr x)))                ; and PUSH a token for them.
 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)             ; Note the beginning of a
 839        `(progn                                    ; constant string.
 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 ;;; Regular Expression match routines.
 898 ;;;
 899 ;;; Here follow a number of pairs of action routines.  These routines are
 900 ;;; in the form of macros for lexical insertion of code into the routines
 901 ;;; regexp: search and match, forward and reverse, which are the recursive
 902 ;;; search routines which actually perform regular expression
 903 ;;; matching.  The macro pairs are for forward and reverse matching
 904 ;;; respectively, and are grouped together for ease of maintenance.
 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 ;;; The actual top-level recursive forward search routines.
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              ;; if we get this far, (caar regexp) = 'begins-line.
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)                              ; (caar regexp) = begins-line
1165               (regexp:match regexp 0 nil))))
1166 ^L
1167 ;;;
1168 ;;; The actual top-level recursive reverse search routines.
1169 ;;; Note that they closely parallel the forward regexp search, but the
1170 ;;; roles of begins-line (^) and ends-line ($) have been interchanged.
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              ;; if we get this far, (caar reverse-regexp) = 'ends-line.
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)                    ; (caar reverse-regexp = ends-line
1214               (regexp:reverse-match reverse-regexp 0 nil))))