1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / src / code / query.lisp
1 ;;;; querying the user: Y-OR-N-P, YES-OR-NO-P
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 (defun query-read-char ()
15   (clear-input *query-io*)
16   (prog1 (read-char *query-io*)
17     (clear-input *query-io*)))
18
19 (defun query-read-line ()
20   (force-output *query-io*)
21   (string-trim " " (read-line *query-io*)))
22
23 (defun maybe-print-query (hint format-string &rest format-args)
24   (fresh-line *query-io*)
25   (when format-string
26     (apply #'format *query-io* format-string format-args)
27     (write-char #\Space *query-io*))
28   (format *query-io* "~A " hint)
29   (finish-output *query-io*))
30
31 (defun clarify-legal-query-input (yes no)
32   (format *query-io* "~&Please type \"~A\" for yes or \"~A\" for no.~%"
33           yes no))
34
35 (defun y-or-n-p (&optional format-string &rest arguments)
36   #!+sb-doc
37   "Y-OR-N-P prints the message, if any, and reads characters from
38    *QUERY-IO* until the user enters y or Y as an affirmative, or either
39    n or N as a negative answer. It asks again if you enter any other
40    characters."
41   (flet ((print-query ()
42            (apply #'maybe-print-query "(y or n)" format-string arguments)))
43     (loop (print-query)
44           (case (query-read-char)
45             ((#\y #\Y) (return t))
46             ((#\n #\N) (return nil))
47             (t (clarify-legal-query-input "y" "n"))))))
48
49 (defun yes-or-no-p (&optional format-string &rest arguments)
50   #!+sb-doc
51   "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
52    input buffer, beeps, and uses READ-LINE to get the strings
53    YES or NO."
54   (flet ((print-query ()
55            (apply #'maybe-print-query "(yes or no)" format-string arguments)))
56     (beep *query-io*)
57     (loop (print-query)
58           (let ((input (query-read-line)))
59             (cond
60               ((string-equal input "yes") (return t))
61               ((string-equal input "no") (return nil))
62               (t (clarify-legal-query-input "yes" "no")))))))