;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.70
;;; Reason:
;;;  Make FORMAT-STRING-STREAM ignore a :beep operation.
;;;  Make FQUERY's readline function only call the stream with a :rubout-handler
;;;  operation if the stream can handle it.
;;; Written 17-Jun-88 17:34:39 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.65, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1760, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.IO1; FQUERY.LISP#58 at 17-Jun-88 17:35:06
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "

(DEFSELECT READLINE-FQUERY-FUNCTION
  (:READ (STREAM &AUX STRING)
    (labels ((read-it ()
	      (if (operation-handled-p stream :rubout-handler)
		  (SETQ STRING (SEND STREAM :RUBOUT-HANDLER '((:EDITING-COMMAND #/HELP)	;Just in case
							      (:PROMPT FQUERY-PROMPT)
							      (:DONT-SAVE T))
				     'FQUERY-READLINE-WITH-HELP STREAM))
		(setq string (send stream :line-in)))
	      (STRING-TRIM '(#/SP) STRING)))
      (if (null fquery-timeout)
	  (read-it)
	(with-timeout (fquery-timeout
			 (values fquery-default-value t))
	  (read-it)))))
  (:ECHO (ECHO STREAM)
    ECHO STREAM)
  (:MEMBER (STRING LIST)
    (MEM #'STRING-EQUAL STRING LIST)))

))

; From modified file DJ: L.IO; FORMAT.LISP#275 at 17-Jun-88 17:35:16
#10R FORMAT#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FORMAT  "

(DEFSELECT (FORMAT-STRING-STREAM FORMAT-STRING-STREAM-DEFAULT-HANDLER)
  ((:TYO :WRITE-CHAR) (CH)
   (OR *FORMAT-STRING* (SETQ *FORMAT-STRING* (MAKE-FORMAT-STRING)))
   (VECTOR-PUSH-EXTEND CH *FORMAT-STRING*))

  (:STRING-OUT (STRING &OPTIONAL (FIRST 0) LAST &AUX NEW-LENGTH)
   (OR *FORMAT-STRING* (SETQ *FORMAT-STRING* (MAKE-FORMAT-STRING)))
   (SETQ LAST (OR LAST (LENGTH STRING)))
   (SETQ NEW-LENGTH (+ (FILL-POINTER *FORMAT-STRING*) (- LAST FIRST)))
   (AND (< (ARRAY-LENGTH *FORMAT-STRING*) NEW-LENGTH)
	(ADJUST-ARRAY-SIZE *FORMAT-STRING* NEW-LENGTH))
   (COPY-ARRAY-PORTION STRING FIRST LAST
		       *FORMAT-STRING* (FILL-POINTER *FORMAT-STRING*) NEW-LENGTH)
   (SETF (FILL-POINTER *FORMAT-STRING*) NEW-LENGTH))

  (:READ-CURSORPOS (&OPTIONAL (MODE :CHARACTER) &AUX POS)
   (OR *FORMAT-STRING* (SETQ *FORMAT-STRING* (MAKE-FORMAT-STRING)))
   (OR (EQ MODE ':CHARACTER)
       (FERROR "Strings only have a width in ~S, not ~S" :CHARACTER MODE))
   (SETQ POS (STRING-REVERSE-SEARCH-CHAR #\NEWLINE *FORMAT-STRING*))
   (VALUES (- (LENGTH *FORMAT-STRING*) (IF POS (+ POS 1) 0))
	   0))

  (:INCREMENT-CURSORPOS (DX DY &OPTIONAL (MODE :CHARACTER) &AUX NEWLEN)
   (OR *FORMAT-STRING* (SETQ *FORMAT-STRING* (MAKE-FORMAT-STRING)))
   (UNLESS (EQ MODE ':CHARACTER)
     (FERROR "Strings can only have a width in ~S, not ~S" :CHARACTER MODE))
   (OR (AND (ZEROP DY) (NOT (MINUSP DX)))
       (FERROR "Cannot do this ~S" :INCREMENT-CURSORPOS))
   (SETQ NEWLEN (+ (LENGTH *FORMAT-STRING*) DX))
   (AND (< (ARRAY-LENGTH *FORMAT-STRING*) NEWLEN)
	(ADJUST-ARRAY-SIZE *FORMAT-STRING* NEWLEN))
   (DO ((I (LENGTH *FORMAT-STRING*) (1+ I)))
       (( I NEWLEN))
     (SETF (CHAR *FORMAT-STRING* I) #\SPACE))
   (SETF (FILL-POINTER *FORMAT-STRING*) NEWLEN))

  (:SET-CURSORPOS (X Y &OPTIONAL (MODE :CHARACTER) &AUX POS DELTA NEWLEN)
   (OR *FORMAT-STRING* (SETQ *FORMAT-STRING* (MAKE-FORMAT-STRING)))
   (UNLESS (EQ MODE :CHARACTER)
     (FERROR "Strings can only have a width in ~S, not ~S" :CHARACTER MODE))
   (SETQ POS (STRING-REVERSE-SEARCH-SET '(#\NEWLINE #\LINE #\FORM) *FORMAT-STRING*)
	 DELTA (- X (- (LENGTH *FORMAT-STRING*) (IF POS (+ POS 1) 0))))
   (OR (AND (ZEROP Y) (PLUSP DELTA))
       (FERROR "Cannot do this ~S" :SET-CURSORPOSE))
   (SETQ NEWLEN (+ (LENGTH *FORMAT-STRING*) DELTA))
   (AND (< (ARRAY-LENGTH *FORMAT-STRING*) NEWLEN)
	(ADJUST-ARRAY-SIZE *FORMAT-STRING* NEWLEN))
   (DO ((I (LENGTH *FORMAT-STRING*) (1+ I)))
       (( I NEWLEN))
     (SETF (CHAR *FORMAT-STRING* I) #\SPACE))
   (SETF (FILL-POINTER *FORMAT-STRING*) NEWLEN))
  (:UNTYO-MARK () (FILL-POINTER *FORMAT-STRING*))
  (:UNTYO (MARK) (SETF (FILL-POINTER *FORMAT-STRING*) MARK))
  (EXTRACT-STRING ()
   (PROG1 *FORMAT-STRING*
	  (SETQ *FORMAT-STRING* NIL)))
  (:FRESH-LINE ()
   (WHEN (NOT (OR (NULL *FORMAT-STRING*)
		  (ZEROP (LENGTH *FORMAT-STRING*))
		  (CHAR= (CHAR *FORMAT-STRING* (1- (LENGTH *FORMAT-STRING*))) #\NEWLINE)))
     (VECTOR-PUSH-EXTEND #\NEWLINE *FORMAT-STRING*)
     T))
  (:beep (ignore)))

))