1.0.4.76: add a new style-warning for duplicate CASE keys
[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 collection. It
36 inhibits both automatically and explicitly triggered collections. Finally,
37 upon leaving the BODY if gc is not inhibited it runs the pending gc.
38 Similarly, if gc is triggered in another thread then it waits until gc is
39 enabled in this thread.
40
41 Implies SB-SYS:WITHOUT-INTERRUPTS for BODY, and causes any nested
42 SB-SYS:WITH-INTERRUPTS to signal a warning during execution of the BODY.
43
44 Should be used with great care, and not at all in multithreaded application
45 code: Any locks that are ever acquired while GC is inhibited need to be always
46 held with GC inhibited to prevent deadlocks: if T1 holds the lock and is
47 stopped for GC while T2 is waiting for the lock inside WITHOUT-GCING the
48 system will be deadlocked. Since SBCL does not currently document its internal
49 locks, application code can never be certain that this invariant is
50 maintained."
51   `(unwind-protect
52         (without-interrupts
53           (let ((*gc-inhibit* t))
54             ,@body))
55      ;; the test is racy, but it can err only on the overeager side
56      (sb!kernel::maybe-handle-pending-gc)))
57
58 \f
59 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
60 (defmacro eof-or-lose (stream eof-error-p eof-value)
61   `(if ,eof-error-p
62        (error 'end-of-file :stream ,stream)
63        ,eof-value))
64
65 ;;; These macros handle the special cases of T and NIL for input and
66 ;;; output streams.
67 ;;;
68 ;;; FIXME: Shouldn't these be functions instead of macros?
69 (defmacro in-synonym-of (stream &optional check-type)
70   (let ((svar (gensym)))
71     `(let ((,svar ,stream))
72        (cond ((null ,svar) *standard-input*)
73              ((eq ,svar t) *terminal-io*)
74              (t ,@(when check-type `((enforce-type ,svar ,check-type))) ;
75                 #!+high-security
76                 (unless (input-stream-p ,svar)
77                   (error 'simple-type-error
78                          :datum ,svar
79                          :expected-type '(satisfies input-stream-p)
80                          :format-control "~S isn't an input stream"
81                          :format-arguments (list ,svar)))
82                 ,svar)))))
83 (defmacro out-synonym-of (stream &optional check-type)
84   (let ((svar (gensym)))
85     `(let ((,svar ,stream))
86        (cond ((null ,svar) *standard-output*)
87              ((eq ,svar t) *terminal-io*)
88              (t ,@(when check-type `((check-type ,svar ,check-type)))
89                 #!+high-security
90                 (unless (output-stream-p ,svar)
91                   (error 'simple-type-error
92                          :datum ,svar
93                          :expected-type '(satisfies output-stream-p)
94                          :format-control "~S isn't an output stream."
95                          :format-arguments (list ,svar)))
96                 ,svar)))))
97
98 ;;; WITH-mumble-STREAM calls the function in the given SLOT of the
99 ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the
100 ;;; ARGS for FUNDAMENTAL-STREAMs.
101 (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
102   `(let ((stream (in-synonym-of ,stream)))
103     ,(if stream-dispatch
104          `(if (ansi-stream-p stream)
105               (funcall (,slot stream) stream ,@args)
106               ,@(when stream-dispatch
107                   `(,(destructuring-bind (function &rest args) stream-dispatch
108                        `(,function stream ,@args)))))
109          `(funcall (,slot stream) stream ,@args))))
110
111 (defmacro with-out-stream/no-synonym (stream (slot &rest args) &optional stream-dispatch)
112   `(let ((stream ,stream))
113     ,(if stream-dispatch
114          `(if (ansi-stream-p stream)
115               (funcall (,slot stream) stream ,@args)
116               ,@(when stream-dispatch
117                   `(,(destructuring-bind (function &rest args) stream-dispatch
118                                          `(,function stream ,@args)))))
119          `(funcall (,slot stream) stream ,@args))))
120
121 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
122   `(with-out-stream/no-synonym (out-synonym-of ,stream)
123     (,slot ,@args) ,stream-dispatch))
124
125 \f
126 ;;;; These are hacks to make the reader win.
127
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 ANSI-STREAM.
131 ;;;
132 ;;; KLUDGE: Some functions (e.g. ANSI-STREAM-READ-LINE) use these variables
133 ;;; directly, instead of indirecting through FAST-READ-CHAR.
134 (defmacro prepare-for-fast-read-char (stream &body forms)
135   `(let* ((%frc-stream% ,stream)
136           (%frc-method% (ansi-stream-in %frc-stream%))
137           (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%))
138           (%frc-index% (ansi-stream-in-index %frc-stream%)))
139      (declare (type index %frc-index%)
140               (type ansi-stream %frc-stream%))
141      ,@forms))
142
143 ;;; This macro must be called after one is done with FAST-READ-CHAR
144 ;;; inside its scope to decache the ANSI-STREAM-IN-INDEX.
145 (defmacro done-with-fast-read-char ()
146   `(setf (ansi-stream-in-index %frc-stream%) %frc-index%))
147
148 ;;; a macro with the same calling convention as READ-CHAR, to be used
149 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR.
150 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
151   `(cond
152     ((not %frc-buffer%)
153      (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
154     ((= %frc-index% +ansi-stream-in-buffer-length+)
155      (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
156             (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
157     (t
158      (prog1 (aref %frc-buffer% %frc-index%)
159             (incf %frc-index%)))))
160
161 ;;;; And these for the fasloader...
162
163 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
164 ;;; method. The stream is assumed to be a ANSI-STREAM.
165 ;;;
166 ;;; KLUDGE: It seems weird to have to remember to explicitly call
167 ;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
168 ;;; already wrapping the stuff inside in a block. Why not rename this
169 ;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
170 ;;; automatically at the end of the block, and eliminate
171 ;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
172 ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
173 (defmacro prepare-for-fast-read-byte (stream &body forms)
174   `(let* ((%frc-stream% ,stream)
175           (%frc-method% (ansi-stream-bin %frc-stream%))
176           (%frc-buffer% (ansi-stream-in-buffer %frc-stream%))
177           (%frc-index% (ansi-stream-in-index %frc-stream%)))
178      (declare (type index %frc-index%)
179               (type ansi-stream %frc-stream%))
180      ,@forms))
181
182 ;;; Similar to fast-read-char, but we use a different refill routine & don't
183 ;;; convert to characters. If ANY-TYPE is true, then this can be used on any
184 ;;; integer streams, and we don't assert the result type.
185 (defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
186   ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
187   `(truly-the
188     ,(if (and (eq eof-error-p t) (not any-type)) '(unsigned-byte 8) t)
189     (cond
190      ((not %frc-buffer%)
191       (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
192      ((= %frc-index% +ansi-stream-in-buffer-length+)
193       (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
194         (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
195      (t
196       (prog1 (aref %frc-buffer% %frc-index%)
197         (incf %frc-index%))))))
198 (defmacro done-with-fast-read-byte ()
199   `(done-with-fast-read-char))