LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031429. :SYSTEM-TYPE :LOGICAL :VERSION 8. :TYPE "LISP" :NAME "FQUERY" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758640008. :AUTHOR "REL3" :LENGTH-IN-BYTES 10543. :LENGTH-IN-BLOCKS 11. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;;;-*- cold-load:t; Mode:Common-Lisp; Package:FORMAT; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **;;; (FQUERY OPTIONS FORMAT-STRING &REST FORMAT-ARGS);;; OPTIONS is a PLIST.  Defined indicators are:;;; :MAKE-COMPLETE boolean.  Send a :MAKE-COMPLETE message to the stream if it understands it.;;; :TYPE one of :TYI, :READLINE.  How typing is gathered and echoed.;;; :CHOICES a list of choices.;;;   A choice is either the symbol :ANY or a list.;;;   If a list, its car is either a possible return value,;;;     or a list of a possible return value and how to echo it.;;;   The remaining things in the list are input items that select that return value.;;;   For a :READLINE type call, they should be strings.;;;   For a :TYI type call, they should be characters.;;;   Example choice: ((:foo "Foo") #/F #\space);;; :FRESH-LINE boolean.  Send a FRESH-LINE to the stream initially.;;; :CONDITION symbol.  Signalled before asking.;;; :LIST-CHOICES boolean.  After prompting in parentheses.;;; :BEEP boolean.  Before printing message.;;; :CLEAR-INPUT boolean.  Before printing message.;;; :SELECT boolean.  Select the window and select back.;;; :HELP-FUNCTION function.  Called with STREAM, CHOICES and TYPE-FUNCTION as arguments.;;; :STREAM stream or expression.  Specifies the stream to use.;;;     If it is a symbol (which is not an io-stream) or a list it is evaluated.;;;     Default is to use QUERY-IO.(defvar fquery-format-string) (defvar fquery-format-args) (defvar fquery-list-choices) (defvar fquery-choices) (defvar fquery-help-function) (defvar fquery-stream) (defun fquery (options fquery-format-string &rest fquery-format-args &aux make-complete type type-function  fquery-choices stream fquery-stream fresh-line condition fquery-list-choices  fquery-help-function beep-p clear-input select handled-p val typein)  "Ask a multiple-choice question on QUERY-IO.FQUERY-FORMAT-STRING and FQUERY-FORMAT-ARGS are used to print the question.Ending the string with \"? \" is often appropriate.OPTIONS is a PLIST.  Defined indicators are::MAKE-COMPLETE boolean.  Send a :MAKE-COMPLETE message to the stream if it understands it.:TYPE one of :TYI, :READLINE, :MINI-BUFFER-OR-READLINE.  It says how the answer is gathered and echoed.:CHOICES a list of choices.  A choice is either the symbol :ANY or a list.  If a list, its car is either a possible return value,    or a list of a possible return value and how to echo it.  The remaining things in the list are input items that select that return value.  For a :READLINE type call, they should be strings.  For a :TYI type call, they should be characters.  Example choice (for :READLINE): ((:foo \"Foo\") #F #\\space):FRESH-LINE boolean.  Send a :FRESH-LINE to the stream initially.:CONDITION symbol.  Signalled before asking.:LIST-CHOICES boolean.  If T, a list of choices is printed after the question.:BEEP boolean.  If T, we beep before printing the message.:CLEAR-INPUT boolean.  If T, we discard type-ahead before printing the message.:SELECT boolean.  Select the window and select back.:HELP-FUNCTION specifies a function to be called  if the user types Help.  It is called with STREAM, CHOICES and TYPE-FUNCTION as arguments.:STREAM stream or expression.  Specifies the stream to use.  If it is a symbol (which is not an io-stream) or a list it is evaluated.  Default is to use QUERY-IO."  (setf    (values make-complete type fquery-choices stream beep-p clear-input select fresh-line    condition fquery-list-choices fquery-help-function)    (apply 'fquery-decode-options options))  (setq fquery-stream(if stream    (if (or (and (symbolp stream) (not (get stream 'si:io-stream-p))) (consp stream))(eval stream)stream)    *query-io*))  (setq type-function(or (get type 'fquery-function) (ferror () "~S is not a valid :TYPE for FQUERY" type)))  (and condition (or (neq condition 'fquery) (eh:condition-name-handled-p condition))       (multiple-value-setq (handled-p val)    (signal-condition      (apply 'make-condition condition options fquery-format-string fquery-format-args)      '(:new-value))))  (if handled-p      val      (unwind-protect   (progn          (block top      (do ()  (nil)(when beep-p (beep))(when clear-input (funcall fquery-stream :clear-input))(when fresh-line (funcall fquery-stream :fresh-line))(setq typein (funcall type-function :read fquery-stream))(dolist (choice fquery-choices)  (cond    ((eq choice :any)     (funcall type-function :echo typein fquery-stream)     (when make-complete       (funcall fquery-stream :send-if-handles :make-complete))     (return-from top typein))    ((funcall type-function :member typein (cdr choice))     (setq choice (car choice))     (when (consp choice)       (funcall type-function :echo (cadr choice) fquery-stream)       (setq choice (car choice)))     (when make-complete       (funcall fquery-stream :send-if-handles :make-complete))     (return-from top choice))))(setq beep-p t      clear-input t      fresh-line t;User spazzed, will need fresh line        fquery-list-choices t))));and should list options))) (defun fquery-decode-options (&key (make-complete t) (type :tyi) (choices y-or-n-p-choices) stream beep  clear-input select (fresh-line t) (condition :fquery) signal-condition (list-choices t)  (help-function 'default-fquery-help))  signal-condition  (values make-complete type choices stream beep clear-input select fresh-line condition  list-choices help-function)) (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 (funcall stream :string-out ") ")))       (funcall stream :string-out(cond  (first-p "(")  ((not (null (cdr choices))) ", ")  (many ", or ")  (t " or ")))       (if (eq (car choices) :any) (funcall stream :string-out "anything else") (progn   (setq choice (cadar choices))   (cond     ((or (numberp choice) (characterp choice)) (format stream "~:@C" choice))     ((equal choice "") (princ "nothing" stream))     (t (funcall stream :string-out choice)))))))) (defun default-fquery-help (stream choices type)  type;Not relevant  (do ((choices choices (cdr choices))       (first-p t nil)       (choice))      ((null choices)       (or first-p (funcall stream :string-out ") ")))    (funcall stream :string-out     (cond       (first-p "(Type ")       ((not (null (cdr choices))) ", ")       (t " or ")))    (setq choice (car choices))    (cond      ((eq choice :any) (princ "anything else" stream))      (t       ;;Print the first input which selects this choice.       ;;Don't confuse the user by mentioning possible alternative inputs.       (cond ((or (numberp (cadr choice))(characterp (cadr choice)))  (format stream "~:@C" (cadr choice))) ((equal (cadr choice) "") (princ "nothing" stream)) (t (funcall stream :string-out (cadr choice))))       ;; If that would echo as something else, say so       (if (consp (car choice)) (format stream " (~A)" (cadar choice))))))) (defprop :tyi tyi-fquery-function fquery-function) (defun  tyi-fquery-function (op arg1 &optional arg2)  (case op(:read;(arg1: stream) (do ((ch))     (nil)   (fquery-prompt arg1 )   (setq ch (funcall arg1 :tyi))   (unless (and (char= ch #\HELP) fquery-help-function)     (return ch))   (funcall fquery-help-function arg1 fquery-choices #'tyi-fquery-function)   (funcall arg1 :fresh-line)))(:echo;(arg1: echo, arg2: stream) (funcall arg2 :string-out (string arg1))) (:member;(arg1: char, arg2: list) (member arg1 arg2 :test #'char-equal))))(defprop :readline readline-fquery-function fquery-function) (defun  readline-fquery-function (op arg1 &optional arg2)  (case op(:read; (stream &aux string) (let ((string       (funcall arg1 :rubout-handler'((:editing-command #+elroy #\help    #-elroy #.(char-code #\HELP));Just in case  (:prompt fquery-prompt) (:dont-save t))#'fquery-readline-with-help arg1)))   (string-trim '(#\SPACE) string)))(:echo arg2)(:member;(arg1: string, arg2: list) (member arg1 arg2 :test #'string-equal))))(defun fquery-readline-with-help (stream)  (do ((string (make-array 20 :element-type 'string-char :fill-pointer 0))       (ch))      (nil)    (setq ch (funcall stream :tyi))    (cond      ((or (null ch) (char= ch #\NEWLINE)) (return string))      ((and (char= ch #\HELP) fquery-help-function) (fresh-line stream)       (funcall fquery-help-function stream fquery-choices #'readline-fquery-function)       (funcall stream :send-if-handles :refresh-rubout-handler))      ((ldb-test sys:%%kbd-control-meta ch))      (t (vector-push-extend ch string))))) (proclaim '(special zwei::*mini-buffer-arg-documenter*))   ;DEFVAR is in ZWEI.(defprop :mini-buffer-or-readline mini-buffer-or-readline-fquery-function fquery-function)  (defun mini-buffer-or-readline-fquery-function (&rest args &aux string)  (cond    ((and (eq (car args) :read) (eq (cadr args) 'zwei::*typein-window*-syn-stream))     (let ((zwei::*mini-buffer-arg-documenter* 'mini-buffer-or-readline-help-function))       (funcall (cadr args) :send-if-handles :make-complete)       (setq string (apply 'zwei:typein-line-readline fquery-format-string fquery-format-args)))     (string-trim '(#\SPACE) string))    (t (apply 'readline-fquery-function args)))) (defun mini-buffer-or-readline-help-function ()  (format *terminal-io* "~&~%You are now typing an answer to a query.~&")  (funcall fquery-help-function *terminal-io* fquery-choices   'mini-buffer-or-readline-fquery-function)) (array-leader format-string 0.) (- last first)))       (and (< (array-total-size format-string) new-length)  (adjust-array format-string (+ (array-total-size format-string) new-length)))       (copy-array-portion string first last format-string (array-leader format-string 0.)   new-length)       (store-array-leader new-length format-string 0.)))    (:read-cursorpos     (let ((mode (or (first args) :character))   pos)       (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))       (setq pos     (position #\NEWLINE (the string (string format-string)) :from-end t :test       