;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.118
;;; Reason:
;;;  FQUERY fixes.  Aside from various logic improvements:
;;;  
;;;  1. <Help> now works with :TYPE :READLINE option.
;;;  
;;;  2. :ANY choice is handled better in prompt and help string. FQUERY will
;;;  display "anything, Y, or N" when :ANY is the first or intermediate
;;;  choice. You see "F, Z, or anything else" when :ANY is last.
;;;  
;;;  
;;;  3. You can specify :ANY for the entire choice-list, which is just like
;;;  (:ANY) -- only one choice, "type anything".
;;;  
;;;    --Keith + PLD
;;; Written 28-Jun-88 16:48:21 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.115, Experimental Local-File 74.3, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, Tiger 28.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, Beta 3 plus patches.



; From modified file DJ: L.IO1; FQUERY.LISP#59 at 28-Jun-88 16:48:52
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "


(DEFUN FQUERY-DECODE-OPTIONS (&KEY (MAKE-COMPLETE T)
			      	   (TYPE :TYI)
				   (CHOICES Y-OR-N-P-CHOICES)
				   STREAM
				   BEEP
				   CLEAR-INPUT
				   (FRESH-LINE T)
				   (CONDITION 'FQUERY)
				   SIGNAL-CONDITION
				   (LIST-CHOICES T)
				   SELECT     ;no longer used
				   (HELP-FUNCTION 'DEFAULT-FQUERY-HELP)
				   DEFAULT-VALUE
				   TIMEOUT)
  SIGNAL-CONDITION SELECT
  (let((choices (if (eq choices :any) '(:any) choices)))
    (VALUES MAKE-COMPLETE TYPE CHOICES STREAM BEEP CLEAR-INPUT
	    FRESH-LINE CONDITION LIST-CHOICES HELP-FUNCTION
	    DEFAULT-VALUE TIMEOUT)))

))

; From modified file DJ: L.IO1; FQUERY.LISP#59 at 28-Jun-88 16:48:55
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "


(defun string-to-handle-any-as-choice(remaining-choices &optional first-p)
  (cond (remaining-choices "anything")
	(first-p "anything")
	(t "anything else")))

))

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


(DEFUN FQUERY-PROMPT (STREAM &REST IGNORE)
  (AND FQUERY-FORMAT-STRING
       (APPLY #'FORMAT STREAM FQUERY-FORMAT-STRING FQUERY-FORMAT-ARGS))
  (AND FQUERY-LIST-CHOICES
       (DO ((CHOICES FQUERY-CHOICES (CDR CHOICES))
	    (FIRST-P T NIL)
	    (MANY (> (LENGTH FQUERY-CHOICES) 2))
	    (CHOICE))
	   ((NULL CHOICES)
	    (OR FIRST-P
		(SEND STREAM :STRING-OUT ") ")))
	 (SEND STREAM :STRING-OUT (COND (FIRST-P "(")
					((NOT (NULL (CDR CHOICES))) ", ")
					(MANY ", or ")
					(T " or ")))
	 (IF (EQ (CAR CHOICES) :ANY)
	     (SEND STREAM :STRING-OUT
		   (string-to-handle-any-as-choice (cdr choices) first-p))
	   (progn
	     (SETQ CHOICE (CADAR CHOICES))
; character lossage
	     (COND ((TYPEP CHOICE '(OR NUMBER CHARACTER))
		    (FORMAT STREAM "~:@C" CHOICE))
		   ((EQUAL CHOICE "")
		    (PRINC "nothing" STREAM))
		   (T
		    (SEND STREAM :STRING-OUT CHOICE)))))))
  (AND FQUERY-TIMEOUT
						;attempt to print out what will return default-value.
       (DO ((CHOICES FQUERY-CHOICES (CDR CHOICES))
	    (choice))
	   ((NULL CHOICES)
	    (FORMAT STREAM "(Automatic default returns ~s after ~a) "
		    fquery-default-value
		    (time:print-interval-or-never
		      (// fquery-timeout 60.)
		      nil)))
	 (setq choice (car choices))
	 (cond ((eq choice :any))
	       ((equal fquery-default-value
		       (if (consp (car choice))
			   (caar choice)
			 (car choice)))
		(return
		  (format stream "(Automatic default after ~a, ~a) "
			  (time:print-interval-or-never
			    (// fquery-timeout 60.)
			    nil)
			  (cadr choice)))))))
  )

))

; From modified file DJ: L.IO1; FQUERY.LISP#59 at 28-Jun-88 16:49:09
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "


(DEFUN DEFAULT-FQUERY-HELP (STREAM CHOICES TYPE)
  (declare(ignore TYPE))			;Not used
  (DO ((CHOICES CHOICES (CDR CHOICES))
       (FIRST-P T NIL)
       (CHOICE))
      ((NULL CHOICES)
       (OR FIRST-P
	   (SEND STREAM :STRING-OUT ") ")))
    (SEND STREAM :STRING-OUT (COND (FIRST-P "(Type ")
				   ((NOT (NULL (CDR CHOICES))) ", ")
				   (T " or ")))
    (SETQ CHOICE (CAR CHOICES))
    (COND ((EQ CHOICE :ANY)
	   (PRINC  (string-to-handle-any-as-choice (cdr choices) first-p) STREAM))
	  (T
	   ;;Print the first input which selects this choice.
	   ;;Don't confuse the user by mentioning possible alternative inputs.
; character lossage
	   (COND ((TYPEP (CADR CHOICE) '(OR NUMBER CHARACTER))
		  (FORMAT STREAM "~:@C" (CADR CHOICE)))
		 ((EQUAL (CADR CHOICE) "")
		  (PRINC "nothing" STREAM))
		 (T
		  (SEND STREAM :STRING-OUT (CADR CHOICE))))
	   ;; If that would echo as something else, say so
	   (IF (CONSP (CAR CHOICE))
	       (FORMAT STREAM " (~A)" (CADAR CHOICE)))))))

))

; From modified file DJ: L.IO1; FQUERY.LISP#59 at 28-Jun-88 16:49:13
#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 ,(char-int #/Help)
										#/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)))

))