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