0.9.5.58:
[sbcl.git] / 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))