iolib.lsp 14.6 KB
Newer Older
1 2 3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

4
;;;;
jjgarcia's avatar
jjgarcia committed
5 6
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
7
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
jjgarcia's avatar
jjgarcia committed
8 9 10 11 12 13 14 15 16 17 18 19
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.
;;;;        The IO library.

(in-package "SYSTEM")

(defmacro with-open-stream ((var stream) &rest body)
20 21 22
  "Syntax: (with-open-stream (var stream-form) {decl}* {form}*)
Evaluates FORMs with VAR bound to the value of STREAM-FORM.  The stream is
automatically closed on exit."
jjgarcia's avatar
jjgarcia committed
23 24 25 26 27 28 29 30
  (multiple-value-bind (ds b)
      (find-declarations body)
    `(LET ((,var ,stream))
       ,@ds
       (UNWIND-PROTECT
         (PROGN ,@b)
         (CLOSE ,var)))))

31
(defmacro with-input-from-string ((var string &key index (start 0) end) &rest body)
32 33 34 35 36
  "Syntax: (with-input-from-string (var string-form {keyword value}*)
           {decl}* {form}*)
Evaluates FORMs with VAR bound to a string input stream from the string that
is the value of STRING-FORM.  The stream is automatically closed on exit.
Possible keywords are :INDEX, :START, and :END."
jjgarcia's avatar
jjgarcia committed
37 38 39 40 41 42
  (if index
      (multiple-value-bind (ds b)
          (find-declarations body)
        `(LET ((,var (MAKE-STRING-INPUT-STREAM ,string ,start ,end)))
           ,@ds
           (UNWIND-PROTECT
43
             (MULTIPLE-VALUE-PROG1
Daniel Kochmański's avatar
Daniel Kochmański committed
44 45
              (PROGN ,@b)
              (SETF ,index (FILE-POSITION ,var)))
46
             (CLOSE ,var))))
jjgarcia's avatar
jjgarcia committed
47 48 49
      `(LET ((,var (MAKE-STRING-INPUT-STREAM ,string ,start ,end)))
         ,@body)))

50
(defmacro with-output-to-string ((var &optional string &rest r &key element-type) &rest body)
51 52 53 54
  "Syntax: (with-output-to-string (var [string-form]) {decl}* {form}*)
Evaluates FORMs with VAR bound to a string output stream to the string that is
the value of STRING-FORM.  If STRING-FORM is not given, a new string is used.
The stream is automatically closed on exit and the string is returned."
jjgarcia's avatar
jjgarcia committed
55
  (if string
56
      `(LET* ((,var (MAKE-STRING-OUTPUT-STREAM-FROM-STRING ,string))
Daniel Kochmański's avatar
Daniel Kochmański committed
57 58 59
              (,(gensym) ,element-type))
        ;; We must evaluate element-type if it has been supplied by the user.
        ;; Even if we ignore the value afterwards.
jjgarcia's avatar
jjgarcia committed
60
         ,@body)
61
      `(LET ((,var (MAKE-STRING-OUTPUT-STREAM ,@r)))
jjgarcia's avatar
jjgarcia committed
62 63 64 65 66 67 68
         ,@body
         (GET-OUTPUT-STREAM-STRING ,var))))

(defun read-from-string (string
                         &optional (eof-error-p t) eof-value
                         &key (start 0) (end (length string))
                              preserve-whitespace)
69 70 71 72 73 74
  "Args: (string &optional (eof-error-p t) (eof-value nil)
              &key (start 0) (end (length string)) (preserve-whitespace nil))
Reads an object from STRING and returns the object.  As the second value,
returns the index to the character next to the object's representation.
PRESERVE-WHITESPACE specifies whether to leave the character next to the
object's representation."
jjgarcia's avatar
jjgarcia committed
75 76 77
  (let ((stream (make-string-input-stream string start end)))
    (if preserve-whitespace
        (values (read-preserving-whitespace stream eof-error-p eof-value)
78
                (file-position stream))
jjgarcia's avatar
jjgarcia committed
79
        (values (read stream eof-error-p eof-value)
80
                (file-position stream)))))
jjgarcia's avatar
jjgarcia committed
81

82 83 84 85
(defun si::string-to-object (string &optional (err-value nil err-value-p))
  (if err-value-p
      (si::safe-eval `(read-from-string ,string) nil err-value)
      (si::safe-eval `(read-from-string ,string) nil)))
86

jjgarcia's avatar
jjgarcia committed
87 88
(defun write-to-string (object &rest rest
                        &aux (stream (make-string-output-stream)))
89 90 91 92 93 94 95
  "Args: (object &key (escape *print-escape*) (radix *print-radix*)
                   (base *print-base*) (circle *print-circle*)
                   (pretty *print-pretty*) (level *print-level*)
                   (length *print-length*) (case *print-case*)
                   (array *print-array*) (gensym *print-gensym*))
Returns as a string the printed representation of OBJECT in the specified
mode.  See the variable docs of *PRINT-...* for the mode."
jjgarcia's avatar
jjgarcia committed
96 97 98 99 100
  (apply #'write object :stream stream rest)
  (get-output-stream-string stream))

(defun prin1-to-string (object
                        &aux (stream (make-string-output-stream)))
101 102 103
  "Args: (object)
PRIN1s OBJECT to a new string and returns the result.  Equivalent to
(WRITE-TO-STRING OBJECT :ESCAPE T)."
jjgarcia's avatar
jjgarcia committed
104 105 106 107 108
   (prin1 object stream)
   (get-output-stream-string stream))

(defun princ-to-string (object
                        &aux (stream (make-string-output-stream)))
109 110 111
  "Args: (object)
PRINCs OBJECT to a new string and returns the result.  Equivalent to
(WRITE-TO-STRING OBJECT :ESCAPE NIL)."
jjgarcia's avatar
jjgarcia committed
112 113 114 115
  (princ object stream)
  (get-output-stream-string stream))

(defmacro with-open-file ((stream . filespec) &rest body)
116 117 118 119
  "Syntax: (with-open-file (var filespec-form {options}*) {decl}* {form}*)
Opens the specified file using OPTIONs, and evaluates FORMs with VAR bound to
a stream to/from the file.  The file is automatically closed on exit.  See
OPEN for the options."
jjgarcia's avatar
jjgarcia committed
120 121 122 123 124 125 126 127 128
  (multiple-value-bind (ds b)
      (find-declarations body)
    `(LET ((,stream (OPEN ,@filespec)))
       ,@ds
       (UNWIND-PROTECT
         (MULTIPLE-VALUE-PROG1 (PROGN ,@b) (WHEN ,stream (CLOSE ,stream)))
         (WHEN ,stream (CLOSE ,stream :ABORT T))))))

(defun y-or-n-p (&optional string &rest args)
129 130 131 132
  "Args: (&optional format-string &rest args)
Asks the user a Y-or-N question.  Does FRESH-LINE, prints a message as if
FORMAT-STRING and ARGs were given to FORMAT, and then prints \"(Y or N)\" is
printed.  If FORMAT-STRING is NIL, however, no prompt will appear."
jjgarcia's avatar
jjgarcia committed
133 134 135 136 137 138 139 140 141 142
  (do ((reply))
      (nil)
    (when string (format *query-io* "~&~?  (Y or N) " string args))
    (setq reply (read *query-io*))
    (cond ((string-equal (symbol-name reply) "Y")
           (return-from y-or-n-p t))
          ((string-equal (symbol-name reply) "N")
           (return-from y-or-n-p nil)))))

(defun yes-or-no-p (&optional string &rest args)
143 144 145 146
  "Args: (&optional format-string &rest args)
Asks the user an YES-or-NO question.  Does FRESH-LINE, prints a message as if
FORMAT-STRING and ARGs were given to FORMAT, and then prints \"(Y or N)\" is
printed.  If FORMAT-STRING is NIL, however, no prompt will appear."
jjgarcia's avatar
jjgarcia committed
147 148 149 150 151 152 153 154 155 156 157 158
  (do ((reply))
      (nil)
    (when string (format *query-io* "~&~?  (Yes or No) " string args))
    (setq reply (read *query-io*))
    (cond ((string-equal (symbol-name reply) "YES")
           (return-from yes-or-no-p t))
          ((string-equal (symbol-name reply) "NO")
           (return-from yes-or-no-p nil)))))

(defun sharp-a-reader (stream subchar arg)
  (declare (ignore subchar))
  (let ((initial-contents (read stream nil nil t)))
159 160 161 162 163
    (cond
      (*read-suppress* nil)
      ((null arg)
        ;; readably-pretty-printed array: #A(type dims initial-contents)
        (let ((elt-type (car initial-contents))
Daniel Kochmański's avatar
Daniel Kochmański committed
164 165 166
              (dims (cadr initial-contents))
              (initial-contents (caddr initial-contents)))
          (make-array dims :element-type elt-type :initial-contents initial-contents)))
167
      (t
168
        (do* ((i 0 (1+ i))
Daniel Kochmański's avatar
Daniel Kochmański committed
169 170
              (d nil (cons (length ic) d))
              (ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
jjgarcia's avatar
jjgarcia committed
171 172
            ((>= i arg)
             (make-array (nreverse d) :initial-contents initial-contents))
Daniel Kochmański's avatar
Daniel Kochmański committed
173
          (declare (fixnum i)))))))
jjgarcia's avatar
jjgarcia committed
174 175 176 177

(set-dispatch-macro-character #\# #\a 'sharp-a-reader)
(set-dispatch-macro-character #\# #\A 'sharp-a-reader)

178
(defun sharp-s-reader (stream subchar arg)
jjgarcia's avatar
jjgarcia committed
179 180 181
  (declare (ignore subchar))
  (when (and arg (null *read-suppress*))
        (error "~S is an extra argument for the #s readmacro." arg))
182
  (let ((l (read stream t nil t)))
jjgarcia's avatar
jjgarcia committed
183
    (when *read-suppress*
184
      (return-from sharp-s-reader nil))
185
    (unless (get-sysprop (car l) 'is-a-structure)
jjgarcia's avatar
jjgarcia committed
186 187 188 189 190
            (error "~S is not a structure." (car l)))
    ;; Intern keywords in the keyword package.
    (do ((ll (cdr l) (cddr ll)))
        ((endp ll)
         ;; Find an appropriate construtor.
191
         (do ((cs (get-sysprop (car l) 'structure-constructors) (cdr cs)))
jjgarcia's avatar
jjgarcia committed
192 193 194 195 196 197 198
             ((endp cs)
              (error "The structure ~S has no structure constructor."
                     (car l)))
           (when (symbolp (car cs))
                 (return (apply (car cs) (cdr l))))))
      (rplaca ll (intern (string (car ll)) 'keyword)))))

199 200
(set-dispatch-macro-character #\# #\s 'sharp-s-reader)
(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
jjgarcia's avatar
jjgarcia committed
201

202
(defparameter *dribble-closure* nil)
jjgarcia's avatar
jjgarcia committed
203

204
(defun dribble (&optional (pathname "DRIBBLE.LOG" psp))
205 206 207 208
  "Args: (&optional filespec)
If FILESPEC is given, starts recording the interaction to the specified file.
FILESPEC may be a symbol, a string, a pathname, or a file stream.  If FILESPEC
is not given, ends the recording."
209
  (cond (*dribble-closure*
Daniel Kochmański's avatar
Daniel Kochmański committed
210 211 212 213 214
         (funcall *dribble-closure* psp))
        ((null psp)
         (error "Not in dribble."))
        (t
         (let* ((namestring (namestring pathname))
jjgarcia's avatar
jjgarcia committed
215
                (stream (open pathname :direction :output
Daniel Kochmański's avatar
Daniel Kochmański committed
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
                              :if-exists :supersede
                              :if-does-not-exist :create))
                (dribble-stream (make-two-way-stream
                                 (make-echo-stream *terminal-io* stream)
                                 (make-broadcast-stream *terminal-io* stream)))
                (standard-input *standard-input*)
                (standard-output *standard-output*)
                (closure #'(lambda (pathname-p)
                             (when pathname-p
                               (error "Already in dribble (to ~A)" namestring))
                             (unless (and (eq dribble-stream *standard-input*)
                                          (eq dribble-stream *standard-output*))
                               (warn "Stream variables rebound while DRIBBLE is on.~%Some output may be lost."))
                             (format stream "~&Finished dribbling to ~A." namestring)
                             (close stream)
                             (setq *standard-input* standard-input
                                   *standard-output* standard-output
                                   *dribble-closure* nil))))
jjgarcia's avatar
jjgarcia committed
234 235
           (multiple-value-bind (sec min hour day month year)
               (get-decoded-time)
236
             (format dribble-stream "~&Starts dribbling to ~A (~d/~d/~d, ~2,'0d:~2,'0d:~2,'0d)."
237
                     namestring year month day hour min sec)
Daniel Kochmański's avatar
Daniel Kochmański committed
238 239 240
             (setq *standard-input* dribble-stream
                   *standard-output* dribble-stream
                   *dribble-closure* closure)))))
241
  (values))
jjgarcia's avatar
jjgarcia committed
242 243

;(provide 'iolib)
244 245

(defmacro with-standard-io-syntax (&body body)
246
  "Syntax: ({forms}*)
247
The forms of the body are executed in a print environment that corresponds to
248 249
the one defined in the ANSI standard. *print-base* is 10, *print-array* is t,
*package* is \"CL-USER\", etc."
250 251
  (with-clean-symbols (%progv-list)
    `(let ((%progv-list +io-syntax-progv-list+))
252
       (progv (si:cons-car %progv-list)
Daniel Kochmański's avatar
Daniel Kochmański committed
253 254
           (si:cons-cdr %progv-list)
         ,@body))))
255

256 257
(defmacro with-ecl-io-syntax (&body body)
  "Syntax: ({forms}*)
258
The forms of the body are executed in a print environment that corresponds to
259
the one used internally by ECL compiled files."
260 261
  (with-clean-symbols (%progv-list)
    `(let ((%progv-list +ecl-syntax-progv-list+))
262
       (progv (si:cons-car %progv-list)
Daniel Kochmański's avatar
Daniel Kochmański committed
263 264
           (si:cons-cdr %progv-list)
         ,@body))))
265

266 267 268 269
#-formatter
(defmacro formatter (control-string)
  `#'(lambda (*standard-output* &rest args)
       (si::formatter-aux *standard-output* ,control-string args)))
270 271

(defmacro print-unreadable-object
Daniel Kochmański's avatar
Daniel Kochmański committed
272
          ((object stream &key type identity) &body body)
273 274
  (if body
      `(flet ((.print-unreadable-object-body. () ,@body))
Daniel Kochmański's avatar
Daniel Kochmański committed
275 276
         (print-unreadable-object-function
           ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
277
    `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
278

279 280
(let* ((basic-encodings
        #+unicode
281
         '(:UTF-8 :UCS-2 :UCS-2BE :UCS-2LE :UCS-4 :UCS-4BE :UCS-4LE
282 283 284 285 286 287 288 289
           :ISO-8859-1 :LATIN-1 :US-ASCII :DEFAULT)
         #-unicode
         '(:DEFAULT))
       (all-encodings nil))
  (defun ext:all-encodings ()
    (or all-encodings
        (progn
          (setf all-encodings basic-encodings)
290
          #+unicode
291
          (dolist (i (directory "sys:encodings;*"))
292
            (push (intern (string-upcase (pathname-name i)) "KEYWORD") all-encodings))
293 294
          all-encodings))))

295
(defun ext:load-encoding (name)
296 297 298
  #-unicode
  (warn "EXT:LOAD-ENCODING not available when ECL is built without support for Unicode")
  #+unicode
299
  (let ((filename (make-pathname :name (symbol-name name) :defaults "sys:encodings;")))
300
    (cond ((probe-file filename)
Daniel Kochmański's avatar
Daniel Kochmański committed
301 302 303 304 305 306 307 308 309 310 311
           (load filename :verbose nil)
           name)
          ((probe-file (setf filename (make-pathname :type "BIN" :defaults filename)))
           (with-open-file (in filename :element-type '(unsigned-byte 16)
                               :external-format :big-endian)
             (let* ((l (read-byte in))
                    (s (make-array l :element-type '(unsigned-byte 16) :initial-element 0)))
               (read-sequence s in)
               s)))
          (t
           (error "Unable to find mapping file ~A for encoding ~A" filename name)))))
312

313
(defun ext:make-encoding (mapping)
314 315 316
  #-unicode
  (error "Not a valid external format ~A" mapping)
  #+unicode
317 318 319 320
  (cond
    ((symbolp mapping)
     (let ((var (intern (symbol-name mapping) (find-package "EXT"))))
       (unless (boundp var)
Daniel Kochmański's avatar
Daniel Kochmański committed
321
         (setf (symbol-value var) (ext::make-encoding (load-encoding mapping))))
322 323 324 325
       (symbol-value var)))
    ((consp mapping)
     (let ((output (make-hash-table :size 512 :test 'eq)))
       (dolist (record mapping output)
Daniel Kochmański's avatar
Daniel Kochmański committed
326 327 328 329 330 331 332
         (let* ((byte (car record))
                (unicode (cdr record))
                (unicode-char (code-char unicode)))
           (when (> byte #xFF)
             (setf (gethash (ash byte -8) output) t))
           (setf (gethash byte output) unicode-char)
           (setf (gethash unicode-char output) byte)))))
333 334
    ((arrayp mapping)
      (do* ((l (array-total-size mapping))
Daniel Kochmański's avatar
Daniel Kochmański committed
335 336 337 338 339 340 341 342 343 344
            (output (make-hash-table :size (floor (* 1.5 l)) :test 'eq))
            (i 0 (+ 2 i)))
           ((>= i l) output)
        (let* ((byte (aref mapping i))
               (unicode (aref mapping (1+ i)))
               (unicode-char (code-char unicode)))
          (when (> byte #xFF)
            (setf (gethash (ash byte -8) output) t))
          (setf (gethash byte output) unicode-char)
          (setf (gethash unicode-char output) byte))))
345 346
    (t
     (error "Not a valid external format ~A" mapping))))