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