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 (defmacro atomic-incf/symbol (symbol-name &optional (delta 1))
  15   #!-sb-thread
  16   `(incf ,symbol-name ,delta)
  17   #!+sb-thread
  18   `(locally
  19     (declare (optimize (safety 0) (speed 3)))
  20     (sb!vm::locked-symbol-global-value-add ',symbol-name ,delta)))
  21
  22 (defvar *gc-inhibit*) ; initialized in cold init
  23
  24 ;;; When the dynamic usage increases beyond this amount, the system
  25 ;;; notes that a garbage collection needs to occur by setting
  26 ;;; *GC-PENDING* to T. It starts out as NIL meaning nobody has figured
  27 ;;; out what it should be yet.
  28 (defvar *gc-pending* nil)
  29
  30 #!+sb-thread
  31 (defvar *stop-for-gc-pending* nil)
  32
  33 (defmacro without-gcing (&body body)
  34   #!+sb-doc
  35   "Executes the forms in the body without doing a garbage
  36 collection. It inhibits both automatically and explicitly triggered
  37 gcs. Finally, upon leaving the BODY if gc is not inhibited it runs the
  38 pending gc. Similarly, if gc is triggered in another thread then it
  39 waits until gc is enabled in this thread."
  40   `(unwind-protect
  41     (let ((*gc-inhibit* t))
  42       ,@body)
  43     ;; the test is racy, but it can err only on the overeager side
  44     (when (and (not *gc-inhibit*)
  45                (or #!+sb-thread *stop-for-gc-pending*
  46                    *gc-pending*))
  47       (sb!unix::receive-pending-interrupt))))
  48
  49 \f
  50 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
  51 (defmacro eof-or-lose (stream eof-error-p eof-value)
  52   `(if ,eof-error-p
  53        (error 'end-of-file :stream ,stream)
  54        ,eof-value))
  55
  56 ;;; These macros handle the special cases of T and NIL for input and
  57 ;;; output streams.
  58 ;;;
  59 ;;; FIXME: Shouldn't these be functions instead of macros?
  60 (defmacro in-synonym-of (stream &optional check-type)
  61   (let ((svar (gensym)))
  62     `(let ((,svar ,stream))
  63        (cond ((null ,svar) *standard-input*)
  64              ((eq ,svar t) *terminal-io*)
  65              (t ,@(when check-type `((enforce-type ,svar ,check-type))) ;
  66                 #!+high-security
  67                 (unless (input-stream-p ,svar)
  68                   (error 'simple-type-error
  69                          :datum ,svar
  70                          :expected-type '(satisfies input-stream-p)
  71                          :format-control "~S isn't an input stream"
  72                          :format-arguments (list ,svar)))
  73                 ,svar)))))
  74 (defmacro out-synonym-of (stream &optional check-type)
  75   (let ((svar (gensym)))
  76     `(let ((,svar ,stream))
  77        (cond ((null ,svar) *standard-output*)
  78              ((eq ,svar t) *terminal-io*)
  79              (t ,@(when check-type `((check-type ,svar ,check-type)))
  80                 #!+high-security
  81                 (unless (output-stream-p ,svar)
  82                   (error 'simple-type-error
  83                          :datum ,svar
  84                          :expected-type '(satisfies output-stream-p)
  85                          :format-control "~S isn't an output stream."
  86                          :format-arguments (list ,svar)))
  87                 ,svar)))))
  88
  89 ;;; WITH-mumble-STREAM calls the function in the given SLOT of the
  90 ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the
  91 ;;; ARGS for FUNDAMENTAL-STREAMs.
  92 (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
  93   `(let ((stream (in-synonym-of ,stream)))
  94     ,(if stream-dispatch
  95          `(if (ansi-stream-p stream)
  96               (funcall (,slot stream) stream ,@args)
  97               ,@(when stream-dispatch
  98                   `(,(destructuring-bind (function &rest args) stream-dispatch
  99                        `(,function stream ,@args)))))
 100          `(funcall (,slot stream) stream ,@args))))
 101
 102 (defmacro with-out-stream/no-synonym (stream (slot &rest args) &optional stream-dispatch)
 103   `(let ((stream ,stream))
 104     ,(if stream-dispatch
 105          `(if (ansi-stream-p stream)
 106               (funcall (,slot stream) stream ,@args)
 107               ,@(when stream-dispatch
 108                   `(,(destructuring-bind (function &rest args) stream-dispatch
 109                                          `(,function stream ,@args)))))
 110          `(funcall (,slot stream) stream ,@args))))
 111
 112 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
 113   `(with-out-stream/no-synonym (out-synonym-of ,stream)
 114     (,slot ,@args) ,stream-dispatch))
 115
 116 \f
 117 ;;;; These are hacks to make the reader win.
 118
 119 ;;; This macro sets up some local vars for use by the
 120 ;;; FAST-READ-CHAR macro within the enclosed lexical scope. The stream
 121 ;;; is assumed to be a ANSI-STREAM.
 122 (defmacro prepare-for-fast-read-char (stream &body forms)
 123   `(let* ((%frc-stream% ,stream)
 124           (%frc-method% (ansi-stream-in %frc-stream%))
 125           (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%))
 126           (%frc-index% (ansi-stream-in-index %frc-stream%)))
 127      (declare (type index %frc-index%)
 128               (type ansi-stream %frc-stream%))
 129      ,@forms))
 130
 131 ;;; This macro must be called after one is done with FAST-READ-CHAR
 132 ;;; inside its scope to decache the ANSI-STREAM-IN-INDEX.
 133 (defmacro done-with-fast-read-char ()
 134   `(setf (ansi-stream-in-index %frc-stream%) %frc-index%))
 135
 136 ;;; a macro with the same calling convention as READ-CHAR, to be used
 137 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR
 138 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
 139   `(cond
 140     ((not %frc-buffer%)
 141      (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 142     ((= %frc-index% +ansi-stream-in-buffer-length+)
 143      (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
 144             (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
 145     (t
 146      (prog1 (aref %frc-buffer% %frc-index%)
 147             (incf %frc-index%)))))
 148
 149 ;;;; And these for the fasloader...
 150
 151 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
 152 ;;; method. The stream is assumed to be a ANSI-STREAM.
 153 ;;;
 154 ;;; KLUDGE: It seems weird to have to remember to explicitly call
 155 ;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
 156 ;;; already wrapping the stuff inside in a block. Why not rename this
 157 ;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
 158 ;;; automatically at the end of the block, and eliminate
 159 ;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
 160 ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
 161 (defmacro prepare-for-fast-read-byte (stream &body forms)
 162   `(let* ((%frc-stream% ,stream)
 163           (%frc-method% (ansi-stream-bin %frc-stream%))
 164           (%frc-buffer% (ansi-stream-in-buffer %frc-stream%))
 165           (%frc-index% (ansi-stream-in-index %frc-stream%)))
 166      (declare (type index %frc-index%)
 167               (type ansi-stream %frc-stream%))
 168      ,@forms))
 169
 170 ;;; Similar to fast-read-char, but we use a different refill routine & don't
 171 ;;; convert to characters. If ANY-TYPE is true, then this can be used on any
 172 ;;; integer streams, and we don't assert the result type.
 173 (defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
 174   ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
 175   `(truly-the
 176     ,(if (and (eq eof-error-p t) (not any-type)) '(unsigned-byte 8) t)
 177     (cond
 178      ((not %frc-buffer%)
 179       (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 180      ((= %frc-index% +ansi-stream-in-buffer-length+)
 181       (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
 182         (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
 183      (t
 184       (prog1 (aref %frc-buffer% %frc-index%)
 185         (incf %frc-index%))))))
 186 (defmacro done-with-fast-read-byte ()
 187   `(done-with-fast-read-char))