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")
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)))
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
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))
49 (defmacro without-gcing (&rest body)
51 "Executes the forms in the body without doing a garbage collection."
53 (let ((*gc-inhibit* t))
55 (when (and *need-to-collect-garbage* (not *gc-inhibit*))
59 (defmacro without-gcing (&rest body)
61 "Executes the forms in the body without doing a garbage collection."
62 `(without-interrupts ,@body))
64 ;;; Eof-Or-Lose is a useful macro that handles EOF.
65 (defmacro eof-or-lose (stream eof-error-p eof-value)
67 (error 'end-of-file :stream ,stream)
70 ;;; These macros handle the special cases of t and nil for input and
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)))
81 (unless (input-stream-p ,svar)
82 (error 'simple-type-error
84 :expected-type '(satisfies input-stream-p)
85 :format-control "~S isn't an input stream"
86 :format-arguments ,(list 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)))
95 (unless (output-stream-p ,svar)
96 (error 'simple-type-error
98 :expected-type '(satisfies output-stream-p)
99 :format-control "~S isn't an output stream."
100 :format-arguments ,(list svar)))
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)))
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))))
116 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
117 `(let ((stream (out-synonym-of ,stream)))
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))))
126 ;;;; These are hacks to make the reader win.
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%))
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%))
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 ()))
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%))))
155 (prog1 (code-char (aref %frc-buffer% %frc-index%))
156 (incf %frc-index%)))))
158 ;;;; And these for the fasloader...
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.
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%))
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
185 ,(if (and (eq eof-error-p 't) (not any-type)) '(unsigned-byte 8) 't)
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%))))
193 (prog1 (aref %frc-buffer% %frc-index%)
194 (incf %frc-index%))))))
195 (defmacro done-with-fast-read-byte ()
196 `(done-with-fast-read-char))