home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / query.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.7 KB  |  80 lines
  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. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: query.lisp,v 1.3 91/02/14 19:03:24 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Querying the user.
  15. ;;; Written by Walter van Roggen, 27 December 1982.
  16. ;;; Brought up to date and fixed somewhat by Rob MacLachlan.
  17. ;;; Modified by Bill Chiles.
  18. ;;;
  19. ;;; These functions are part of the standard Spice Lisp environment.
  20. ;;;
  21. ;;; **********************************************************************
  22. ;;;
  23.  
  24. (in-package "LISP")
  25.  
  26. (export '(y-or-n-p yes-or-no-p))
  27.  
  28. (eval-when (compile)
  29.   (defmacro query-readline ()
  30.     `(string-trim "     " (read-line *query-io*))))
  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.     (force-output *query-io*))
  43.   (loop
  44.     (let* ((line (query-readline))
  45.        (ans (if (string= line "")
  46.             #\? ;Force CASE below to issue instruction.
  47.             (schar line 0))))
  48.       (unless (whitespacep ans)
  49.     (case ans
  50.       ((#\y #\Y) (return t))
  51.       ((#\n #\N) (return nil))
  52.       (t
  53.        (write-line "Type \"y\" for yes or \"n\" for no. " *query-io*)
  54.        (when format-string
  55.          (apply #'format *query-io* format-string arguments))
  56.        (force-output *query-io*)))))))
  57.  
  58. ;;; YES-OR-NO-P  --  Public.
  59. ;;;
  60. ;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and
  61. ;;; uses READ-LINE to get "YES" or "NO".
  62. ;;;
  63. (defun yes-or-no-p (&optional format-string &rest arguments)
  64.   "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the 
  65.    input buffer, beeps, and uses READ-LINE to get the strings 
  66.    YES or NO."
  67.   (clear-input *query-io*)
  68.   (beep)
  69.   (when format-string
  70.     (fresh-line *query-io*)
  71.     (apply #'format *query-io* format-string arguments))
  72.   (do ((ans (query-readline) (query-readline)))
  73.       (())
  74.     (cond ((string-equal ans "YES") (return t))
  75.       ((string-equal ans "NO") (return nil))
  76.       (t
  77.        (write-line "Type \"yes\" for yes or \"no\" for no. " *query-io*)
  78.        (when format-string
  79.          (apply #'format *query-io* format-string arguments))))))
  80.