1 ;;;; miscellaneous system hacking macros
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
16 (defmacro atomic-incf
(symbol-name &optional
(delta 1))
17 `(incf ,symbol-name
,delta
))
19 (defmacro atomic-decf
(place &optional
(delta 1))
20 `(atomic-incf ,place
,(- delta
)))
23 (defmacro without-gcing
(&rest body
)
25 "Executes the forms in the body without doing a garbage collection."
28 (atomic-incf *gc-inhibit
*)
30 (atomic-decf *gc-inhibit
*)
31 (when (and *need-to-collect-garbage
* (zerop *gc-inhibit
*))
35 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
36 (defmacro eof-or-lose
(stream eof-error-p eof-value
)
38 (error 'end-of-file
:stream
,stream
)
41 ;;; These macros handle the special cases of T and NIL for input and
44 ;;; FIXME: Shouldn't these be functions instead of macros?
45 (defmacro in-synonym-of
(stream &optional check-type
)
46 (let ((svar (gensym)))
47 `(let ((,svar
,stream
))
48 (cond ((null ,svar
) *standard-input
*)
49 ((eq ,svar t
) *terminal-io
*)
50 (T ,@(when check-type
`((enforce-type ,svar
,check-type
)))
52 (unless (input-stream-p ,svar
)
53 (error 'simple-type-error
55 :expected-type
'(satisfies input-stream-p
)
56 :format-control
"~S isn't an input stream"
57 :format-arguments
,(list svar
)))
59 (defmacro out-synonym-of
(stream &optional check-type
)
60 (let ((svar (gensym)))
61 `(let ((,svar
,stream
))
62 (cond ((null ,svar
) *standard-output
*)
63 ((eq ,svar t
) *terminal-io
*)
64 (T ,@(when check-type
`((check-type ,svar
,check-type
)))
66 (unless (output-stream-p ,svar
)
67 (error 'simple-type-error
69 :expected-type
'(satisfies output-stream-p
)
70 :format-control
"~S isn't an output stream."
71 :format-arguments
,(list svar
)))
74 ;;; WITH-mumble-STREAM calls the function in the given SLOT of the
75 ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the
76 ;;; ARGS for FUNDAMENTAL-STREAMs.
77 (defmacro with-in-stream
(stream (slot &rest args
) &optional stream-dispatch
)
78 `(let ((stream (in-synonym-of ,stream
)))
80 `(if (ansi-stream-p stream
)
81 (funcall (,slot stream
) stream
,@args
)
82 ,@(when stream-dispatch
83 `(,(destructuring-bind (function &rest args
) stream-dispatch
84 `(,function stream
,@args
)))))
85 `(funcall (,slot stream
) stream
,@args
))))
87 (defmacro with-out-stream
(stream (slot &rest args
) &optional stream-dispatch
)
88 `(let ((stream (out-synonym-of ,stream
)))
90 `(if (ansi-stream-p stream
)
91 (funcall (,slot stream
) stream
,@args
)
92 ,@(when stream-dispatch
93 `(,(destructuring-bind (function &rest args
) stream-dispatch
94 `(,function stream
,@args
)))))
95 `(funcall (,slot stream
) stream
,@args
))))
97 ;;;; These are hacks to make the reader win.
99 ;;; This macro sets up some local vars for use by the
100 ;;; FAST-READ-CHAR macro within the enclosed lexical scope. The stream
101 ;;; is assumed to be a ANSI-STREAM.
102 (defmacro prepare-for-fast-read-char
(stream &body forms
)
103 `(let* ((%frc-stream%
,stream
)
104 (%frc-method%
(ansi-stream-in %frc-stream%
))
105 (%frc-buffer%
(ansi-stream-in-buffer %frc-stream%
))
106 (%frc-index%
(ansi-stream-in-index %frc-stream%
)))
107 (declare (type index %frc-index%
)
108 (type ansi-stream %frc-stream%
))
111 ;;; This macro must be called after one is done with FAST-READ-CHAR
112 ;;; inside its scope to decache the ANSI-STREAM-IN-INDEX.
113 (defmacro done-with-fast-read-char
()
114 `(setf (ansi-stream-in-index %frc-stream%
) %frc-index%
))
116 ;;; a macro with the same calling convention as READ-CHAR, to be used
117 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR
118 (defmacro fast-read-char
(&optional
(eof-error-p t
) (eof-value ()))
121 (funcall %frc-method% %frc-stream%
,eof-error-p
,eof-value
))
122 ((= %frc-index%
+ansi-stream-in-buffer-length
+)
123 (prog1 (fast-read-char-refill %frc-stream%
,eof-error-p
,eof-value
)
124 (setq %frc-index%
(ansi-stream-in-index %frc-stream%
))))
126 (prog1 (code-char (aref %frc-buffer% %frc-index%
))
127 (incf %frc-index%
)))))
129 ;;;; And these for the fasloader...
131 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
132 ;;; method. The stream is assumed to be a ANSI-STREAM.
134 ;;; KLUDGE: It seems weird to have to remember to explicitly call
135 ;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
136 ;;; already wrapping the stuff inside in a block. Why not rename this
137 ;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
138 ;;; automatically at the end of the block, and eliminate
139 ;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
140 ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
141 (defmacro prepare-for-fast-read-byte
(stream &body forms
)
142 `(let* ((%frc-stream%
,stream
)
143 (%frc-method%
(ansi-stream-bin %frc-stream%
))
144 (%frc-buffer%
(ansi-stream-in-buffer %frc-stream%
))
145 (%frc-index%
(ansi-stream-in-index %frc-stream%
)))
146 (declare (type index %frc-index%
)
147 (type ansi-stream %frc-stream%
))
150 ;;; Similar to fast-read-char, but we use a different refill routine & don't
151 ;;; convert to characters. If ANY-TYPE is true, then this can be used on any
152 ;;; integer streams, and we don't assert the result type.
153 (defmacro fast-read-byte
(&optional
(eof-error-p t
) (eof-value ()) any-type
)
154 ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
156 ,(if (and (eq eof-error-p t
) (not any-type
)) '(unsigned-byte 8) t
)
159 (funcall %frc-method% %frc-stream%
,eof-error-p
,eof-value
))
160 ((= %frc-index%
+ansi-stream-in-buffer-length
+)
161 (prog1 (fast-read-byte-refill %frc-stream%
,eof-error-p
,eof-value
)
162 (setq %frc-index%
(ansi-stream-in-index %frc-stream%
))))
164 (prog1 (aref %frc-buffer% %frc-index%
)
165 (incf %frc-index%
))))))
166 (defmacro done-with-fast-read-byte
()
167 `(done-with-fast-read-char))