home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / iolib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  6.6 KB  |  196 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;   iolib.lsp
  21. ;;;;
  22. ;;;;        The IO library.
  23.  
  24.  
  25. (in-package 'lisp)
  26.  
  27.  
  28. (export '(with-open-stream with-input-from-string with-output-to-string))
  29. (export '(read-from-string))
  30. (export '(write-to-string prin1-to-string princ-to-string))
  31. (export 'with-open-file)
  32. (export '(y-or-n-p yes-or-no-p))
  33. (export 'dribble)
  34.  
  35.  
  36. (in-package 'system)
  37.  
  38.  
  39. (proclaim '(optimize (safety 2) (space 3)))
  40.  
  41.  
  42. (defmacro with-open-stream ((var stream) . body)
  43.   (multiple-value-bind (ds b)
  44.       (find-declarations body)
  45.     `(let ((,var ,stream))
  46.        ,@ds
  47.        (unwind-protect
  48.          (progn ,@b)
  49.          (close ,var)))))
  50.  
  51.  
  52. (defmacro with-input-from-string ((var string &key index start end) . body)
  53.   (if index
  54.       (multiple-value-bind (ds b)
  55.           (find-declarations body)
  56.         `(let ((,var (make-string-input-stream ,string ,start ,end)))
  57.            ,@ds
  58.            (unwind-protect
  59.              (progn ,@b)
  60.              (setf ,index (si:get-string-input-stream-index ,var)))))
  61.       `(let ((,var (make-string-input-stream ,string ,start ,end)))
  62.          ,@body)))
  63.  
  64.  
  65. (defmacro with-output-to-string ((var &optional string) . body)
  66.   (if string
  67.       `(let ((,var (make-string-output-stream-from-string ,string)))
  68.          ,@body)
  69.       `(let ((,var (make-string-output-stream)))
  70.          ,@body
  71.          (get-output-stream-string ,var))))
  72.         
  73.  
  74. (defun read-from-string (string
  75.                          &optional (eof-error-p t) eof-value
  76.                          &key (start 0) (end (length string))
  77.                               preserve-whitespace)
  78.   (let ((stream (make-string-input-stream string start end)))
  79.     (if preserve-whitespace
  80.         (values (read-preserving-whitespace stream eof-error-p eof-value)
  81.                 (si:get-string-input-stream-index stream))
  82.         (values (read stream eof-error-p eof-value)
  83.                 (si:get-string-input-stream-index stream)))))
  84.  
  85.  
  86. (defun write-to-string (object &rest rest
  87.                         &key escape radix base
  88.                              circle pretty level length
  89.                              case gensym array
  90.                         &aux (stream (make-string-output-stream)))
  91.   (declare (ignore escape radix base
  92.                    circle pretty level length
  93.                    case gensym array))
  94.   (apply #'write object :stream stream rest)
  95.   (get-output-stream-string stream))
  96.  
  97.  
  98. (defun prin1-to-string (object
  99.                         &aux (stream (make-string-output-stream)))
  100.    (prin1 object stream)
  101.    (get-output-stream-string stream))
  102.  
  103.  
  104. (defun princ-to-string (object
  105.                         &aux (stream (make-string-output-stream)))
  106.   (princ object stream)
  107.   (get-output-stream-string stream))
  108.  
  109.  
  110. (defmacro with-open-file ((stream . filespec) . body)
  111.   (multiple-value-bind (ds b)
  112.       (find-declarations body)
  113.     `(let ((,stream (open ,@filespec)))
  114.        ,@ds
  115.        (unwind-protect
  116.          (progn ,@b)
  117.          (close ,stream)))))
  118.  
  119.  
  120. (defun y-or-n-p (&optional string &rest args)
  121.   (do ((reply))
  122.       (nil)
  123.     (when string (format *query-io* "~&~?  (Y or N) " string args))
  124.     (setq reply (read *query-io*))
  125.     (cond ((string-equal (symbol-name reply) "Y")
  126.            (return-from y-or-n-p t))
  127.           ((string-equal (symbol-name reply) "N")
  128.            (return-from y-or-n-p nil)))))
  129.  
  130.  
  131. (defun yes-or-no-p (&optional string &rest args)
  132.   (do ((reply))
  133.       (nil)
  134.     (when string (format *query-io* "~&~?  (Yes or No) " string args))
  135.     (setq reply (read *query-io*))
  136.     (cond ((string-equal (symbol-name reply) "YES")
  137.            (return-from yes-or-no-p t))
  138.           ((string-equal (symbol-name reply) "NO")
  139.            (return-from yes-or-no-p nil)))))
  140.  
  141.  
  142. (defun sharp-a-reader (stream subchar arg)
  143.   (declare (ignore subchar))
  144.   (let ((initial-contents (read stream nil nil t)))
  145.     (if *read-suppress*
  146.         nil
  147.         (do ((i 0 (1+ i))
  148.              (d nil (cons (length ic) d))
  149.              (ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
  150.             ((>= i arg)
  151.              (make-array (nreverse d)
  152.                          :initial-contents initial-contents))))))
  153.  
  154. (set-dispatch-macro-character #\# #\a 'sharp-a-reader)
  155. (set-dispatch-macro-character #\# #\A 'sharp-a-reader)
  156.  
  157. ;; defined in defstruct.lsp
  158. (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
  159. (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  160.  
  161. (defvar *dribble-stream* nil)
  162. (defvar *dribble-io* nil)
  163. (defvar *dribble-namestring* nil)
  164. (defvar *dribble-saved-terminal-io* nil)
  165.  
  166. (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede))
  167.   (cond ((not psp)
  168.          (when (null *dribble-stream*) (error "Not in dribble."))
  169.          (if (eq *dribble-io* *terminal-io*)
  170.              (setq *terminal-io* *dribble-saved-terminal-io*)
  171.              (warn "*TERMINAL-IO* was rebound while DRIBBLE is on.~%~
  172.                    You may miss some dribble output."))
  173.          (close *dribble-stream*)
  174.          (setq *dribble-stream* nil)
  175.          (format t "~&Finished dribbling to ~A." *dribble-namestring*))
  176.         (*dribble-stream*
  177.          (error "Already in dribble (to ~A)." *dribble-namestring*))
  178.         (t
  179.          (let* ((namestring (namestring pathname))
  180.                 (stream (open pathname :direction :output
  181.                                        :if-exists f
  182.                                        :if-does-not-exist :create)))
  183.            (setq *dribble-namestring* namestring
  184.                  *dribble-stream* stream
  185.                  *dribble-saved-terminal-io* *terminal-io*
  186.                  *dribble-io* (make-two-way-stream
  187.                                (make-echo-stream *terminal-io* stream)
  188.                                (make-broadcast-stream *terminal-io* stream))
  189.                  *terminal-io* *dribble-io*)
  190.            (multiple-value-bind (sec min hour day month year)
  191.                (get-decoded-time)
  192.              (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."
  193.                      namestring year month day hour min sec))))))
  194.  
  195.  
  196.