;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.266
;;; Reason:
;;;  Fix zwei "C-sh-S" (Lisp Match Search) command.  No longer loops at end
;;;  of buffer if pattern not found.  "#" now matches exactly one s-exp.
;;;  Don't enter EH if given a string with nothing but delimiters.
;;; Written 9-May-88 14:17:38 by pld at site Gigamos Cambridge
;;; while running on Azathoth from band 3
;;; with Experimental System 123.264, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.2, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.ZWEI; COMH.LISP#20 at 9-May-88 14:46:38
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMH  "

(DEFUN LISP-MATCH-SEARCH (BP STRING &OPTIONAL REVERSEP FIXUP-P IGNORE LIMIT-BP
			  &AUX (START 0) (END (LENGTH STRING))
			       (final-limit-bp (if reversep
						   (interval-first-bp *interval*)
						 (interval-last-bp *interval*))))
  "Search from BP for Lisp code that matches against STRING.
Matching at any given place is done with LISP-STRING-BUFFER-MATCH.
Differences in whitespace characters are ignored except when quoted or inside strings.
The characters # as an atom in the STRING match any sexp in the buffer.
The characters ... as an atom in the STRING match any number of sexps.

If a match is found, the value is a bp to the end (start, if reverse) of the matching text.
A second value is a bp to the start (end, if reverse) of the matching text.

REVERSEP means search backward from BP; the code matched must end before BP.
 Otherwise, search goes forward from BP.
LIMIT-BP is a place to stop searching; the matched code cannot
 continue past there in forward search or begin before there in backward search.
FIXUP-P says what to do if no match is found.
 T means return the end of the range to be searched
 (either LIMIT-BP or the beginning or end of the interval).
 NIL means return NIL.  Second value is NIL in either case."
  ;; Ignore leading delimiter chars in STRING.
  (DO ()
      ((OR (= START END)
	   (NOT (= LIST-DELIMITER (LIST-SYNTAX (CHAR STRING START))))))
    (INCF START))
  ;; Strings that start with ... or # are handled specially.
  (COND ((= START END)
	 (AND FIXUP-P (OR LIMIT-BP FINAL-LIMIT-BP)))
	((AND (STRING-EQUAL STRING "..." :START1 START :END1 (+ START 3))
	      (OR (= (+ START 3) END)
		  (NOT (MEMQ (LIST-SYNTAX (CHAR STRING (+ START 3)))
			     '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE)))))
	 (BARF "A search pattern starting with ... is not meaningful."))
	((AND (STRING-EQUAL STRING "#" :START1 START :END1 (+ START 1))
	      (OR (= (+ START 2) END)
		  (NOT (MEMQ (LIST-SYNTAX (CHAR STRING (+ START 2)))
			     '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE)))))
	 (LET ((TAIL-FOUND (LISP-MATCH-SEARCH (FORWARD-SEXP BP 1 T)
					      (SUBSTRING STRING (+ START 3)))))
	   (OR (AND TAIL-FOUND
		    (FORWARD-SEXP TAIL-FOUND -1 NIL 0 BP T T))
	       (AND FIXUP-P LIMIT-BP FINAL-LIMIT-BP))))
	(REVERSEP
	 (LET ((BP1 (COPY-BP BP))
	       TEM)
	   (DO-FOREVER
	     (SETQ BP1 (ZWEI-SEARCH BP1 (CHAR STRING START) T NIL NIL
				    (OR LIMIT-BP FINAL-LIMIT-BP)))
	     (UNLESS BP1 (RETURN (AND FIXUP-P (OR LIMIT-BP FINAL-LIMIT-BP))))
	     (IF (SETQ TEM (LISP-STRING-BUFFER-MATCH BP1 BP STRING START))
		 (RETURN (VALUES BP1 TEM))))))
	(T
	 (LET ((BP1 (COPY-BP BP))
	       TEM)
	   (DO-FOREVER
	     (SETQ BP1 (ZWEI-SEARCH BP1 (CHAR STRING START) NIL NIL NIL LIMIT-BP))
	     (UNLESS BP1 (RETURN (AND FIXUP-P (OR LIMIT-BP FINAL-LIMIT-BP))))
	     (DBP BP1)
	     (IF (SETQ TEM (LISP-STRING-BUFFER-MATCH BP1 (OR LIMIT-BP FINAL-LIMIT-BP)
						     STRING START))
		 (RETURN (VALUES TEM BP1)))
	     (IF (OR (BP-= BP1 LIMIT-BP) (BP-= BP1 FINAL-LIMIT-BP))
		 (RETURN (IF FIXUP-P BP1)))
	     (UNLESS (IBP BP1) (RETURN (IF FIXUP-P BP1 NIL))))))))

))

; From modified file DJ: L.ZWEI; COMH.LISP#20 at 9-May-88 15:05:20
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMH  "

(DEFUN LISP-STRING-BUFFER-MATCH (START-BP LIMIT-BP PATTERN-STRING &OPTIONAL (START 0) END)
  "Match part of a string against part of an editor buffer, comparing as Lisp code.
The string is PATTERN-STRING; START and END specify the range to use.
The buffer text starts at START-BP.  It will not match past LIMIT-BP.
If there is a match, the value is a bp to the end of the buffer text matched.
Otherwise, the value is NIL.
Differences in whitespace characters are ignored except when quoted or inside strings.
The characters # as an atom in the PATTERN-STRING match any sexp in the buffer.
The characters ... as an atom in the PATTERN-STRING match any number of sexps."
  (UNLESS END (SETQ END (LENGTH PATTERN-STRING)))
  (DO-NAMED OUTER
	    ((I START (1+ I))
	     (BP (COPY-BP START-BP))
	     IN-STRING QUOTED IN-COMMENT IN-ATOM
	     (P-SYN -1))
	    ((= I END) BP)
    (IF (BP-= LIMIT-BP BP)
	(RETURN NIL))
    (LET* ((S-CHAR (CHAR PATTERN-STRING I))
	   (S-SYN (LIST-SYNTAX S-CHAR)))
      ;; S-SYN is this pattern character's syntax.
      ;; P-SYN is the previous significant pattern character's syntax.
      ;; It is LIST-ALPHABETIC iff the last pattern character, not counting delimiters,
      ;; was such as to be part of an atom.  This is the case in which
      ;; at least one delimiter is required in the buffer in order to match.
      (COND (IN-STRING
	     ;; First update the syntactic state.
	     (COND (QUOTED (SETQ QUOTED NIL))
		   ((= S-SYN LIST-DOUBLE-QUOTE)
		    (SETQ IN-STRING NIL))
		   ((= S-SYN LIST-SLASH)
		    (SETQ QUOTED T)))
	     ;; Now always match against buffer.
	     (UNLESS (EQ S-CHAR (BP-CH-CHARACTER BP))
	       (RETURN NIL))
	     (SETQ P-SYN -1)
	     (IBP BP))
	    (IN-COMMENT
	     (IF (EQ S-CHAR #/RETURN) (SETQ IN-COMMENT NIL))
	     ;; Now always match against buffer.
	     (UNLESS (CHAR-EQUAL S-CHAR (BP-CHARACTER BP))
	       (RETURN NIL))
	     (SETQ P-SYN -1)
	     (IBP BP))
	    (QUOTED
	     (SETQ QUOTED NIL)
	     ;; Quoted char, always match against buffer.
	     (UNLESS (EQ S-CHAR (BP-CH-CHARACTER BP))
	       (RETURN NIL))
	     (SETQ P-SYN LIST-ALPHABETIC)
	     (IBP BP))
	    ;; Not in string or comment, not slashified.
	    ((= S-SYN LIST-DELIMITER)
	     ;; Just skip all delimiters in the pattern.
	     (SETQ IN-ATOM NIL))
	    ((AND (NOT IN-ATOM)
		  (<= (+ I 3) END)
		  (STRING-EQUAL PATTERN-STRING "..." :START1 I :END1 (+ I 3))
		  (OR (= (+ I 3) END)
		      (NOT (MEMQ (LIST-SYNTAX (CHAR PATTERN-STRING (+ I 3)))
				 '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE)))))
	     ;; "..." has been encountered, and its an atom by itself.
	     (DO-FOREVER
	       ;; Try matching the rest of the pattern at one spot.
	       (LET ((TEM (LISP-STRING-BUFFER-MATCH BP LIMIT-BP PATTERN-STRING (+ I 3) END)))
		 (WHEN TEM
		   (RETURN-FROM OUTER TEM)))
	       ;; SKip one more sexp and try again.
	       (SETQ BP (FORWARD-SEXP BP 1 NIL 0 LIMIT-BP NIL T))
	       (UNLESS BP (RETURN NIL))))
	    ((AND (NOT IN-ATOM)
		  (<= (1+ I) END)
		  (STRING-EQUAL PATTERN-STRING "#" :START1 I :END1 (1+ I))
		  (OR (= (1+ I) END)
		      (NOT (MEMQ (LIST-SYNTAX (CHAR PATTERN-STRING (1+ I)))
				 '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE)))))
	     ;; "#" has been encountered as an atom in the pattern.
	     ;; SKip it, and skip one sexp in the buffer, then keep matching.
	     (SETQ BP (FORWARD-SEXP BP 1 NIL 0 LIMIT-BP NIL T))
	     (SETQ P-SYN -1)
	     (UNLESS BP (RETURN NIL)))
	    (T
	     ;; Skip all delimiters here in the buffer, if not within an atom.
	     (UNLESS IN-ATOM
	       (DO ((COUNT 0 (1+ COUNT)))  ;Count number of delimiters skipped.
		   ((NOT (= LIST-DELIMITER (LIST-SYNTAX (BP-CHARACTER BP))))
		    (AND (ZEROP COUNT)
			 (= S-SYN LIST-ALPHABETIC)
			 (= P-SYN LIST-ALPHABETIC)
			 (RETURN-FROM OUTER NIL)))
		 (IBP BP)))
	     ;; Set up syntax context of next pattern character.
	     (SELECT S-SYN
	       (LIST-DOUBLE-QUOTE
		(SETQ IN-STRING T))
	       (LIST-SLASH
		(SETQ QUOTED T))
	       (LIST-COMMENT
		(SETQ IN-COMMENT T))
	       (LIST-ALPHABETIC
		(SETQ IN-ATOM T)))
	     (IF (EQ S-CHAR #/.) (SETQ IN-ATOM T))
	     ;; Now always match against buffer.
	     (UNLESS (CHAR-EQUAL S-CHAR (BP-CHARACTER BP))
	       (RETURN NIL))
	     (IBP BP)
	     (SETQ P-SYN S-SYN))))))

))