/[cmucl]/src/code/query.lisp
ViewVC logotype

Contents of /src/code/query.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.7: +3 -3 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/query.lisp,v 1.8 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Querying the user.
13 ;;; Written by Walter van Roggen, 27 December 1982.
14 ;;; Brought up to date and fixed somewhat by Rob MacLachlan.
15 ;;; Modified by Bill Chiles.
16 ;;;
17 ;;; These functions are part of the standard Spice Lisp environment.
18 ;;;
19 ;;; **********************************************************************
20 ;;;
21
22 (in-package "LISP")
23 (intl:textdomain "cmucl")
24
25 (export '(y-or-n-p yes-or-no-p))
26
27 (defun query-readline ()
28 (force-output *query-io*)
29 (string-trim " " (read-line *query-io*)))
30
31
32 ;;; Y-OR-N-P -- Public.
33 ;;;
34 (defun y-or-n-p (&optional format-string &rest arguments)
35 "Y-OR-N-P prints the message, if any, and reads characters from *QUERY-IO*
36 until the user enters y or Y as an affirmative, or either n or N as a
37 negative answer. It ignores preceding whitespace and asks again if you
38 enter any other characters."
39 (when format-string
40 (fresh-line *query-io*)
41 (apply #'format *query-io* format-string arguments))
42 (loop
43 (let* ((line (query-readline))
44 (ans (if (string= line "")
45 #\? ;Force CASE below to issue instruction.
46 (schar line 0))))
47 (unless (whitespacep ans)
48 (case ans
49 ((#\y #\Y) (return t))
50 ((#\n #\N) (return nil))
51 (t
52 (write-line (intl:gettext "Type \"y\" for yes or \"n\" for no. ") *query-io*)
53 (when format-string
54 (apply #'format *query-io* format-string arguments))
55 (force-output *query-io*)))))))
56
57 ;;; YES-OR-NO-P -- Public.
58 ;;;
59 ;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and
60 ;;; uses READ-LINE to get "YES" or "NO".
61 ;;;
62 (defun yes-or-no-p (&optional format-string &rest arguments)
63 "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
64 input buffer, beeps, and uses READ-LINE to get the strings
65 YES or NO."
66 (clear-input *query-io*)
67 (beep)
68 (when format-string
69 (fresh-line *query-io*)
70 (apply #'format *query-io* format-string arguments))
71 (do ((ans (query-readline) (query-readline)))
72 (())
73 (cond ((string-equal ans "YES") (return t))
74 ((string-equal ans "NO") (return nil))
75 (t
76 (write-line (intl:gettext "Type \"yes\" for yes or \"no\" for no. ") *query-io*)
77 (when format-string
78 (apply #'format *query-io* format-string arguments))))))

  ViewVC Help
Powered by ViewVC 1.1.5