src/code/sysmacs.lisp

   1 ;;;; miscellaneous system hacking macros
   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 ;;; This checks to see whether the array is simple and the start and
  15 ;;; end are in bounds. If so, it proceeds with those values.
  16 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that there is a
  17 ;;; DERIVE-TYPE method for %WITH-ARRAY-DATA.
  18 (defmacro with-array-data (((data-var array &key (offset-var (gensym)))
  19                             (start-var &optional (svalue 0))
  20                             (end-var &optional (evalue nil)))
  21                            &body forms)
  22   #!+sb-doc
  23   "Given any Array, binds Data-Var to the array's data vector and Start-Var and
  24   End-Var to the start and end of the designated portion of the data vector.
  25   Svalue and Evalue are any start and end specified to the original operation,
  26   and are factored into the bindings of Start-Var and End-Var. Offset-Var is
  27   the cumulative offset of all displacements encountered, and does not
  28   include Svalue."
  29   (once-only ((n-array array)
  30               (n-svalue `(the index ,svalue))
  31               (n-evalue `(the (or index null) ,evalue)))
  32     `(multiple-value-bind (,data-var ,start-var ,end-var ,offset-var)
  33          (if (not (array-header-p ,n-array))
  34              (let ((,n-array ,n-array))
  35                (declare (type (simple-array * (*)) ,n-array))
  36                ,(once-only ((n-len `(length ,n-array))
  37                             (n-end `(or ,n-evalue ,n-len)))
  38                   `(if (<= ,n-svalue ,n-end ,n-len)
  39                        (values ,n-array ,n-svalue ,n-end 0)
  40                        (%with-array-data ,n-array ,n-svalue ,n-evalue))))
  41              (%with-array-data ,n-array ,n-svalue ,n-evalue))
  42        (declare (ignorable ,offset-var))
  43        ,@forms)))
  44
  45 #!-gengc
  46 (defmacro without-gcing (&rest body)
  47   #!+sb-doc
  48   "Executes the forms in the body without doing a garbage collection."
  49   `(unwind-protect
  50        (let ((*gc-inhibit* t))
  51          ,@body)
  52      (when (and *need-to-collect-garbage* (not *gc-inhibit*))
  53        (maybe-gc nil))))
  54
  55 #!+gengc
  56 (defmacro without-gcing (&rest body)
  57   #!+sb-doc
  58   "Executes the forms in the body without doing a garbage collection."
  59   `(without-interrupts ,@body))
  60 \f
  61 ;;; Eof-Or-Lose is a useful macro that handles EOF.
  62 (defmacro eof-or-lose (stream eof-error-p eof-value)
  63   `(if ,eof-error-p
  64        (error 'end-of-file :stream ,stream)
  65        ,eof-value))
  66
  67 ;;; These macros handle the special cases of t and nil for input and
  68 ;;; output streams.
  69 ;;;
  70 ;;; FIXME: Shouldn't these be functions instead of macros?
  71 (defmacro in-synonym-of (stream &optional check-type)
  72   (let ((svar (gensym)))
  73     `(let ((,svar ,stream))
  74        (cond ((null ,svar) *standard-input*)
  75              ((eq ,svar t) *terminal-io*)
  76              (T ,@(if check-type `((check-type ,svar ,check-type)))
  77                 #!+high-security
  78                 (unless (input-stream-p ,svar)
  79                   (error 'simple-type-error
  80                          :datum ,svar
  81                          :expected-type '(satisfies input-stream-p)
  82                          :format-control "~S isn't an input stream"
  83                          :format-arguments ,(list  svar)))
  84                 ,svar)))))
  85 (defmacro out-synonym-of (stream &optional check-type)
  86   (let ((svar (gensym)))
  87     `(let ((,svar ,stream))
  88        (cond ((null ,svar) *standard-output*)
  89              ((eq ,svar t) *terminal-io*)
  90              (T ,@(if check-type `((check-type ,svar ,check-type)))
  91                 #!+high-security
  92                 (unless (output-stream-p ,svar)
  93                   (error 'simple-type-error
  94                          :datum ,svar
  95                          :expected-type '(satisfies output-stream-p)
  96                          :format-control "~S isn't an output stream."
  97                          :format-arguments ,(list  svar)))
  98                 ,svar)))))
  99
 100 ;;; With-Mumble-Stream calls the function in the given Slot of the
 101 ;;; Stream with the Args for lisp-streams, or the Function with the
 102 ;;; Args for fundamental-streams.
 103 (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
 104   `(let ((stream (in-synonym-of ,stream)))
 105     ,(if stream-dispatch
 106          `(if (lisp-stream-p stream)
 107               (funcall (,slot stream) stream ,@args)
 108               ,@(when stream-dispatch
 109                   `(,(destructuring-bind (function &rest args) stream-dispatch
 110                        `(,function stream ,@args)))))
 111          `(funcall (,slot stream) stream ,@args))))
 112
 113 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
 114   `(let ((stream (out-synonym-of ,stream)))
 115     ,(if stream-dispatch
 116          `(if (lisp-stream-p stream)
 117               (funcall (,slot stream) stream ,@args)
 118               ,@(when stream-dispatch
 119                   `(,(destructuring-bind (function &rest args) stream-dispatch
 120                                          `(,function stream ,@args)))))
 121          `(funcall (,slot stream) stream ,@args))))
 122 \f
 123 ;;;; These are hacks to make the reader win.
 124
 125 ;;; This macro sets up some local vars for use by the
 126 ;;; Fast-Read-Char macro within the enclosed lexical scope. The stream
 127 ;;; is assumed to be a lisp-stream.
 128 (defmacro prepare-for-fast-read-char (stream &body forms)
 129   `(let* ((%frc-stream% ,stream)
 130           (%frc-method% (lisp-stream-in %frc-stream%))
 131           (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
 132           (%frc-index% (lisp-stream-in-index %frc-stream%)))
 133      (declare (type index %frc-index%)
 134               (type lisp-stream %frc-stream%))
 135      ,@forms))
 136
 137 ;;; This macro must be called after one is done with fast-read-char
 138 ;;; inside its scope to decache the lisp-stream-in-index.
 139 (defmacro done-with-fast-read-char ()
 140   `(setf (lisp-stream-in-index %frc-stream%) %frc-index%))
 141
 142 ;;;    a macro with the same calling convention as READ-CHAR, to be
 143 ;;; used within the scope of a PREPARE-FOR-FAST-READ-CHAR
 144 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
 145   `(cond
 146     ((not %frc-buffer%)
 147      (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 148     ((= %frc-index% in-buffer-length)
 149      (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
 150             (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
 151     (t
 152      (prog1 (code-char (aref %frc-buffer% %frc-index%))
 153             (incf %frc-index%)))))
 154
 155 ;;;; And these for the fasloader...
 156
 157 ;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin
 158 ;;; method. The stream is assumed to be a lisp-stream.
 159 ;;;
 160 ;;; KLUDGE: It seems weird to have to remember to explicitly call
 161 ;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
 162 ;;; already wrapping the stuff inside in a block. Why not rename this
 163 ;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
 164 ;;; automatically at the end of the block, and eliminate
 165 ;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
 166 ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
 167 (defmacro prepare-for-fast-read-byte (stream &body forms)
 168   `(let* ((%frc-stream% ,stream)
 169           (%frc-method% (lisp-stream-bin %frc-stream%))
 170           (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
 171           (%frc-index% (lisp-stream-in-index %frc-stream%)))
 172      (declare (type index %frc-index%)
 173               (type lisp-stream %frc-stream%))
 174      ,@forms))
 175
 176 ;;; Similar to fast-read-char, but we use a different refill routine & don't
 177 ;;; convert to characters. If ANY-TYPE is true, then this can be used on any
 178 ;;; integer streams, and we don't assert the result type.
 179 (defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
 180   ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
 181   `(truly-the
 182     ,(if (and (eq eof-error-p 't) (not any-type)) '(unsigned-byte 8) 't)
 183     (cond
 184      ((not %frc-buffer%)
 185       (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 186      ((= %frc-index% in-buffer-length)
 187       (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
 188         (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
 189      (t
 190       (prog1 (aref %frc-buffer% %frc-index%)
 191         (incf %frc-index%))))))
 192 (defmacro done-with-fast-read-byte ()
 193   `(done-with-fast-read-char))