;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 124.103 ;;; Reason: ;;; ZWEI incremental search understands Control-W to append word at cursor ;;; to the search string. ;;; Written 24-Jun-88 14:53:11 by smh (Steve Haflich) at site Gigamos Cambridge ;;; while running on Alex from band 3 ;;; with Experimental System 124.87, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1756, SDU Boot Tape 3.12, SDU ROM 102, K-environment. ; From modified file DJ: L.ZWEI; COMS.LISP#93 at 24-Jun-88 14:53:51 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMS  " (DEFCOM COM-INCREMENTAL-SEARCH "Search for character string. As characters are typed in the accumulated string is displayed and searched for. You can use Rubout to cancel characters characters. Altmode exits the search (but if search string is empty, it invokes String Search). Use Control-Q to quote, Control-S to repeat the search with the same string, Control-R to search backwards, Control-W adds the word at the cursor to the string. If Control-S or Control-R is the first character typed, the previous search string is used again." (KM) (INCREMENTAL-SEARCH (< *NUMERIC-ARG* 0))) )) ; From modified file DJ: L.ZWEI; COMS.LISP#93 at 24-Jun-88 14:53:53 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMS  " (DEFCOM COM-REVERSE-INCREMENTAL-SEARCH "Reverse search for character string. As characters are typed in the accumulated string is displayed and searched for. You can use Rubout to cancel characters characters. Altmode exits the search (but if search string is empty, it invokes String Search). Use Control-Q to quote, Control-R to repeat the search with the same string, Control-S to search forwards, Control-W adds the word at the cursor to the string. If Control-S or Control-R is the first character typed, the previous search string is used again." (KM) (INCREMENTAL-SEARCH (> *NUMERIC-ARG* 0))) )) ; From modified file DJ: L.ZWEI; COMS.LISP#93 at 24-Jun-88 14:54:03 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMS  " (DEFUN INCREMENTAL-SEARCH (REVERSE-P &AUX (ORIG-PT (COPY-BP (POINT))) ISEARCH-VECTORS) (SELECT-WINDOW *WINDOW*) (SEND *QUERY-IO* :FRESH-LINE) ;Necessary if in the mini-buffer (UNWIND-PROTECT (TYPEIN-LINE-ACTIVATE (PROG* (CHAR ; The current command. XCHAR ; Upcase version of character MUST-REDIS ; T => The echo-area must be completely redisplayed. (P 0) ; The stack pointer into *IS-BP*, etc. for input and rubout (P1 0) ; The pointer for which search we are doing. ; Can never exceed P. SUPPRESSED-REDISPLAY ; T if the last input char was read before ; redisplay had a chance to finish. ; A Control-G read that way acts like ; a failing search quit. BP1 ; Aux BP used for actual searching. NEW-BP TIME-OUT ; Set by SEARCH when it times out so we can check input. INPUT-DONE ; An altmode or control char has been seen. ; Do not look for input any more; just search, then exit. (*is-string*) (*is-bp*) (*is-status*) (*is-reverse-p*) (*is-pointer*) (*is-operation*) ; (TV:KBD-INTERCEPTED-CHARACTERS ; (COPY-LIST TV:KBD-INTERCEPTED-CHARACTERS)) ) ; (SETQ TV:KBD-INTERCEPTED-CHARACTERS ; (DELQ (ASSQ #/ABORT TV:KBD-INTERCEPTED-CHARACTERS) ; TV:KBD-INTERCEPTED-CHARACTERS)) (SETQ ISEARCH-VECTORS (ALLOCATE-RESOURCE 'ISEARCH-VECTORS) *IS-STRING* (SVREF ISEARCH-VECTORS 0) *IS-BP* (SVREF ISEARCH-VECTORS 1) *IS-STATUS* (SVREF ISEARCH-VECTORS 2) *IS-REVERSE-P* (SVREF ISEARCH-VECTORS 3) *IS-POINTER* (SVREF ISEARCH-VECTORS 4) *IS-OPERATION* (SVREF ISEARCH-VECTORS 5)) (SETF (AREF *IS-STATUS* 0) T) ; Initialize the stacks. (SETF (AREF *IS-REVERSE-P* 0) REVERSE-P) (SETF (AREF *IS-OPERATION* 0) ':NORMAL) (SETF (AREF *IS-POINTER* 0) 0) (SETF (AREF *IS-BP* 0) (COPY-BP (POINT))) (SETQ MUST-REDIS T) ; Initially we must redisplay. (GO CHECK-FOR-INPUT) ;; Come here if there is input, or nothing to do until there is input. INPUT (SETQ SUPPRESSED-REDISPLAY NIL) (AND (WINDOW-READY-P *WINDOW*) ;In case of minibuffer (REDISPLAY *WINDOW* :POINT)) ; Redisplay point position while waiting. (IF (= (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-NONE) (REDISPLAY-MODE-LINE) ;Update indication of more above or below. (SETQ SUPPRESSED-REDISPLAY T)) (IF SUPPRESSED-REDISPLAY (SETQ CHAR (TYI-WITH-SCROLLING NIL T)) ;; If must wait for input, make the window's blinker blink ;; even though not selected. (IF (OPERATION-HANDLED-P *WINDOW* :POINT-BLINKER) (UNWIND-PROTECT (PROGN (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY :BLINK) (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :BLINK) (SETQ CHAR (TYI-WITH-SCROLLING NIL T))) (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY ;tv lossage (IF (EQ *WINDOW* TV:SELECTED-WINDOW) :BLINK (TV:SHEET-EXPOSED-P *WINDOW*))) (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :ON)) (SETQ CHAR (TYI-WITH-SCROLLING NIL T)))) (COND ((CONSP CHAR) (SEND *STANDARD-INPUT* :UNTYI CHAR) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT)) ; character lossage ((FIXNUMP CHAR) (SETQ CHAR (INT-CHAR CHAR)))) (SETQ XCHAR (CHAR-UPCASE CHAR)) (COND ((NOT (OR ( (CHAR-BITS CHAR) 0) (TV:CHAR-MOUSE-P CHAR) (MEMQ CHAR '(#/ #/END #/RUBOUT #/HELP #/ABORT #/CLEAR-INPUT)))) (GO NORMAL)) ((MEMQ XCHAR '(#/C-S #/C-R)) (PUSH-ISEARCH-STATUS) (SETF (AREF *IS-OPERATION* P) ':REPEAT) (LET ((NEW-REVERSE-P (EQL XCHAR #/C-R))) (COND ;; In reverse mode, just go to forward. ((NEQ (AREF *IS-REVERSE-P* P) NEW-REVERSE-P) (SETF (AREF *IS-REVERSE-P* P) NEW-REVERSE-P) (SETQ MUST-REDIS T) (SETF (AREF *IS-OPERATION* P) ':REVERSE)) ((ZEROP (AREF *IS-POINTER* P)) (LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF))))) (COPY-ARRAY-CONTENTS STRING *IS-STRING*) (SETF (AREF *IS-POINTER* P) (LENGTH STRING))) (SETQ MUST-REDIS T)))) (GO CHECK-FOR-INPUT)) ((eql char #/C-W) ;snarf word at cursor - smh 24jun88 (let* ((saved-point (point)) (pointer (if (aref *is-reverse-p* p) (forward-char saved-point (aref *is-pointer* p)) (copy-bp saved-point))) (other-end (or (forward-word pointer 1) (progn (beep) ;; at end of file, just flash and wait for more (go check-for-input))))) (PUSH-ISEARCH-STATUS) (loop while (bp-< pointer other-end) as char = (int-char (bp-char pointer)) do (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR)) (LET ((IDX (AREF *IS-POINTER* P))) (AND ( IDX (ARRAY-LENGTH *IS-STRING*)) (ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 64.))) (SETF (CHAR *IS-STRING* IDX) CHAR) (SETF (AREF *IS-POINTER* P) (1+ IDX))) (SETF (AREF *IS-OPERATION* P) ':NORMAL) (setq pointer (forward-char pointer 1))) (move-bp (point) saved-point) (go check-for-input))) ((EQL XCHAR #/C-Q) (LET ((NEW-CH (READ-CHAR *STANDARD-INPUT*))) (SETQ CHAR (IF (CHAR-BIT NEW-CH :CONTROL) ;; ascii version of control characters (INT-CHAR (LOGAND #o37 (CHAR-CODE NEW-CH))) (INT-CHAR (CHAR-CODE NEW-CH))))) (GO NORMAL)) ((EQL CHAR #/HELP) (PRINT-DOC :FULL *CURRENT-COMMAND*) (SEND *STANDARD-INPUT* :UNTYI (SEND *STANDARD-INPUT* :ANY-TYI)) (GO INPUT)) ((OR (EQL XCHAR #/C-G) (EQL XCHAR #/ABORT)) (BEEP) (COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T)) (PLUSP P)) ;; Control-G in other than a successful search ;; rubs out until it becomes successful. (SETQ P (DO ((P (1- P) (1- P))) ((EQ (AREF *IS-STATUS* P) T) P))) (SETQ P1 (MIN P P1) MUST-REDIS T) (GO CHECK-FOR-INPUT)) (T (MOVE-BP (POINT) (AREF *IS-BP* 0)) (RETURN)))) ((OR (EQL CHAR #/) (EQL CHAR #/END)) (AND (ZEROP P) ;; Call string search, and make self-doc print the right thing there. (LET ((*CURRENT-COMMAND* 'COM-STRING-SEARCH-INTERNAL)) (RETURN (COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL)))) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT)) ((OR (EQL CHAR #/RUBOUT) (EQL CHAR #/CLEAR-INPUT)) ;; Clear-input rubs out all the way. Set P to 1 and let it be decremented. (IF (EQL CHAR #/CLEAR-INPUT) (SETQ P 1)) (COND (( P 0) ; If he over-rubbed out, (BEEP) ; that is an error. (GO CHECK-FOR-INPUT)) (T ;; Rubout pops all of these PDLs. (SETQ P (1- P)) (SETQ P1 (MIN P P1)) (SETQ MUST-REDIS T) (GO CHECK-FOR-INPUT)))) (T ;character lossage (SEND *STANDARD-INPUT* :UNTYI (CHAR-INT CHAR)) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT))) (FERROR "A clause fell through.") ;; Normal chars to be searched for come here. NORMAL (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR)) (PUSH-ISEARCH-STATUS) (LET ((IDX (AREF *IS-POINTER* P))) (AND ( IDX (ARRAY-LENGTH *IS-STRING*)) (ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 64.))) (SETF (CHAR *IS-STRING* IDX) CHAR) (SETF (AREF *IS-POINTER* P) (1+ IDX))) (SETF (AREF *IS-OPERATION* P) ':NORMAL) ;; Come here after possibly processing input to update the search tables ;; to search for a while. First, if necessary and not suppressed ;; update the search string displayed in the echo area. CHECK-FOR-INPUT ;; If there is input available, go read it. ;; Otherwise, do work if there is work to be done. (AND (NOT INPUT-DONE) (SEND *STANDARD-INPUT* :LISTEN) (GO INPUT)) ;; Now do some work for a while, then go back to CHECK-FOR-INPUT. (WHEN MUST-REDIS (SETQ MUST-REDIS NIL) (FORMAT *QUERY-IO* "~&~:|") (OR (AREF *IS-STATUS* P1) (FORMAT *QUERY-IO* "Failing ")) (AND (AREF *IS-REVERSE-P* P) (FORMAT *QUERY-IO* "Reverse ")) (FORMAT *QUERY-IO* "I-Search: ") (SETF (FILL-POINTER *IS-STRING*) (AREF *IS-POINTER* P)) (FORMAT *QUERY-IO* "~A" *IS-STRING*)) ;; Now see what sort of state the actual search is in, and what work there is to do. ;; P1 points at the level of the table on which we are actually working. (SETF BP1 (AREF *IS-BP* P1)) ;; Display point at the end of the last search level which has succeeded. (DO ((P0 P1 (1- P0))) ((EQ (AREF *IS-STATUS* P0) T) (MOVE-BP (POINT) (AREF *IS-BP* P0)))) (MUST-REDISPLAY *WINDOW* DIS-BPS) (COND ((EQ (AREF *IS-STATUS* P1) ':GO) (SETF (FILL-POINTER *IS-STRING*) (AREF *IS-POINTER* P1)) ;; If the level we were working on is still not finished, ;; search at most 64. more lines. If we find it or the end of the buffer ;; before then, this level is determined and we can work on the next. ;; Otherwise, we remain in the :GO state and do 64. more lines next time. (MULTIPLE-VALUE (NEW-BP TIME-OUT) (ZWEI-SEARCH BP1 *IS-STRING* (AREF *IS-REVERSE-P* P1) NIL 64.)) ;; What happened? (COND (TIME-OUT ;; Nothing determined. NEW-BP has where we stopped. (MOVE-BP BP1 NEW-BP) (DBP BP1)) ;Avoids missing occurrences, if string starts with CR ((NULL NEW-BP) ;; This search was determined to be a failure. (OR (SEND-IF-HANDLES *STANDARD-INPUT* :MACRO-ERROR) (BEEP)) (SETF (AREF *IS-STATUS* P1) NIL) (MOVE-BP BP1 (AREF *IS-BP* (1- P1))) (MOVE-BP (POINT) BP1) (SETQ MUST-REDIS T)) (T ;; This search level has succeeded. (SETF (AREF *IS-STATUS* P1) T) (MOVE-BP (POINT) NEW-BP) (MOVE-BP BP1 NEW-BP)))) (( P P1) ;; This level is finished, but there are more pending levels typed ahead. (INCF P1) (SETF (AREF *IS-BP* P1) (SETQ BP1 (COPY-BP BP1))) (SETF (FILL-POINTER *IS-STRING*) (AREF *IS-POINTER* P1)) (COND ((NULL (AREF *IS-STATUS* (1- P1))) (COND ((NEQ (AREF *IS-OPERATION* P1) ':REVERSE) ;; A failing search remains so unless we reverse direction. (SETF (AREF *IS-STATUS* P1) NIL)) (T ;; If we reverse direction, change prompt line. (SETQ MUST-REDIS T)))) ((EQ (AREF *IS-OPERATION* P1) ':NORMAL) ;; Normal char to be searched for comes next. ;; We must adjust the bp at which we start to search ;; so as to allow the user to extend the string already found. (MOVE-BP BP1 (FORWARD-CHAR BP1 (IF (AREF *IS-REVERSE-P* P1) (IF (= (LENGTH *IS-STRING*) 1) 0 (LENGTH *IS-STRING*)) (- 1 (LENGTH *IS-STRING*))) T))))) ;; If there is nothing left to do, and terminator seen, exit. (INPUT-DONE (SEARCH-RING-PUSH ;; Entries on the search ring should have a leader (STRING-NCONC (MAKE-STRING (LENGTH *IS-STRING*) :FILL-POINTER 0) *IS-STRING*) 'ZWEI-SEARCH) (FORMAT *QUERY-IO* "") (MAYBE-PUSH-POINT ORIG-PT) ;(SELECT-WINDOW *WINDOW*) (RETURN)) ;; Nothing to do and no terminator, wait for input. (T (GO INPUT))) (GO CHECK-FOR-INPUT) ) (SETQ ORIG-PT NIL)) ;; unwind-protect cleanup (IF ISEARCH-VECTORS (DEALLOCATE-RESOURCE 'ISEARCH-VECTORS ISEARCH-VECTORS)) (IF ORIG-PT (MOVE-BP (POINT) ORIG-PT)) (SEND-IF-HANDLES *QUERY-IO* :MAKE-COMPLETE) (MUST-REDISPLAY *WINDOW* DIS-BPS) (SEND *MODE-LINE-WINDOW* :DONE-WITH-MODE-LINE-WINDOW)) DIS-BPS) ;; Subroutine used by the WITH-REGION-OR-WHOLE-INTERVAL ))