1 ;;;; various user-level definitions which need to be done particularly
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!IMPL")
15 ;;; Helper for making the DX closure allocation in macros expanding
16 ;;; to CALL-WITH-FOO less ugly.
17 (defmacro dx-flet
(functions &body forms
)
19 (declare (truly-dynamic-extent ,@(mapcar (lambda (func) `#',(car func
))
23 ;;; Another similar one.
24 (defmacro dx-let
(bindings &body forms
)
26 (declare (truly-dynamic-extent
27 ,@(mapcar (lambda (bind) (if (listp bind
) (car bind
) bind
))
31 ;;;; target constants which need to appear as early as possible
33 ;;; an internal tag for marking empty slots, which needs to be defined
34 ;;; as early as possible because it appears in macroexpansions for
35 ;;; iteration over hash tables
37 ;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty
38 ;;; since it's easily accessible to the user, so that e.g.
39 ;;; (DEFVAR *HT* (MAKE-HASH-TABLE))
40 ;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY)
41 ;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V)))
42 ;;; gives no output -- oops!
44 ;;; FIXME: It'd probably be good to use the unbound marker for this.
45 ;;; However, there might be some gotchas involving assumptions by
46 ;;; e.g. AREF that they're not going to return the unbound marker,
47 ;;; and there's also the noted-below problem that the C-level code
48 ;;; contains implicit assumptions about this marker.
50 ;;; KLUDGE: Note that as of version 0.pre7 there's a dependence in the
51 ;;; gencgc.c code on this value being a symbol. (This is only one of
52 ;;; several nasty dependencies between that code and this, alas.)
54 (defconstant +empty-ht-slot
+ '%empty-ht-slot%
)
55 ;;; Q: What "mess" should we not need?
56 ;;; We shouldn't need this mess now that EVAL-WHEN works.
58 ;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
59 ;;; getting nonconforming behavior by messing around with
60 ;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
61 ;;; now we just don't worry about it. If for some reason it becomes
62 ;;; worrisome and the magic value needs replacement:
63 ;;; * The replacement value needs to be LOADable with EQL preserved,
64 ;;; so that the macroexpansion for WITH-HASH-TABLE-ITERATOR will
65 ;;; work when compiled into a file and loaded back into SBCL.
66 ;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.)
67 ;;; * The replacement value needs to be acceptable to the
68 ;;; low-level gencgc.lisp hash table scavenging code.
69 ;;; * The change will break binary compatibility, since comparisons
70 ;;; against the value used at the time of compilation are wired
74 ;; Define "exchanged subtract" So that DECF on a symbol requires no LET binding:
75 ;; (DECF I (EXPR)) -> (SETQ I (XSUBTRACT (EXPR) I))
76 ;; which meets the CLHS 5.1.3 requirement to eval (EXPR) prior to reading
77 ;; the old value of I. Formerly in 'setf' but too late to avoid full calls.
78 (declaim (inline xsubtract
))
79 (defun xsubtract (a b
) (- b a
))
83 ;;; Automate an idiom often found in macros:
84 ;;; (LET ((FOO (GENSYM "FOO"))
85 ;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
88 ;;; "Good notation eliminates thought." -- Eric Siggia
90 ;;; Incidentally, this is essentially the same operator which
91 ;;; _On Lisp_ calls WITH-GENSYMS.
92 (defmacro with-unique-names
(symbols &body body
)
93 (declare (notinline every
)) ; because we can't inline ALPHA-CHAR-P
94 `(let ,(mapcar (lambda (symbol)
95 (let* ((symbol-name (symbol-name symbol
))
96 (stem (if (every #'alpha-char-p symbol-name
)
98 (concatenate 'string symbol-name
"-"))))
99 `(,symbol
(sb!xc
:gensym
,stem
))))
103 ;;; Return a list of N gensyms. (This is a common suboperation in
104 ;;; macros and other code-manipulating code.)
105 (declaim (ftype (function (unsigned-byte &optional t
) (values list
&optional
))
107 (defun make-gensym-list (n &optional name
)
108 (let ((arg (if name
(string name
) "G")))
109 (loop repeat n collect
(sb!xc
:gensym arg
))))
113 ;;; Lots of code wants to get to the KEYWORD package or the
114 ;;; COMMON-LISP package without a lot of fuss, so we cache them in
115 ;;; variables on the host, or use L-T-V forms on the target.
116 (macrolet ((def-it (sym expr
)
118 `(progn (declaim (type package
,sym
))
121 ;; We don't need to declaim the type. FIND-PACKAGE
122 ;; returns a package, and L-T-V propagates types.
123 ;; It's ugly how it achieves that, but it's a separate concern.
124 `(define-symbol-macro ,sym
(load-time-value ,expr t
))))
125 (def-it *cl-package
* (find-package "COMMON-LISP"))
126 (def-it *keyword-package
* (find-package "KEYWORD")))
128 (declaim (inline singleton-p
))
129 (defun singleton-p (list)
130 (and (listp list
) (null (rest list
)) list
))
132 ;;; Concatenate together the names of some strings and symbols,
133 ;;; producing a symbol in the current package.
134 (defun symbolicate (&rest things
)
135 (declare (dynamic-extent things
))
138 (if (singleton-p things
)
139 (string (first things
))
140 (let* ((length (reduce #'+ things
141 :key
(lambda (x) (length (string x
)))))
142 (name (make-array length
:element-type
'character
))
144 (dolist (thing things name
)
145 (let ((x (string thing
)))
146 (replace name x
:start1 index
)
147 (incf index
(length x
)))))))))
151 (sb!xc
:gensym
(symbol-name x
))
154 ;;; like SYMBOLICATE, but producing keywords
155 (defun keywordicate (&rest things
)
156 (let ((*package
* *keyword-package
*))
157 (apply #'symbolicate things
)))
159 ;;; Access *PACKAGE* in a way which lets us recover when someone has
160 ;;; done something silly like (SETF *PACKAGE* :CL-USER) in unsafe code.
161 ;;; (Such an assignment is undefined behavior, so it's sort of reasonable for
162 ;;; it to cause the system to go totally insane afterwards, but it's a
163 ;;; fairly easy mistake to make, so let's try to recover gracefully instead.)
164 (defun sane-package ()
165 ;; Perhaps it's possible for *PACKAGE* to be set to a non-package in some
166 ;; host Lisp, but in SBCL it isn't, and the PACKAGEP test below would be
167 ;; elided unless forced to be NOTINLINE.
168 (declare (notinline packagep
))
169 (let* ((maybe-package *package
*)
170 (packagep (packagep maybe-package
)))
171 ;; And if we don't also always check for deleted packages - as was true
172 ;; when the "#+sb-xc-host" reader condition was absent - then half of the
173 ;; COND becomes unreachable, making this function merely return *PACKAGE*
174 ;; in the cross-compiler, producing a code deletion note.
176 ;; For good measure, we also catch the problem of
177 ;; *PACKAGE* being bound to a deleted package.
178 ;; Technically, this is not undefined behavior in itself,
179 ;; but it will immediately lead to undefined to behavior,
180 ;; since almost any operation on a deleted package is
182 (package-%name maybe-package
))
185 ;; We're in the undefined behavior zone. First, munge the
186 ;; system back into a defined state.
187 (let ((really-package
188 (load-time-value (find-package :cl-user
) t
)))
189 (setf *package
* really-package
)
191 (error 'simple-type-error
193 :expected-type
'(and package
(satisfies package-name
))
195 "~@<~S can't be a ~A: ~2I~_It has been reset to ~S.~:>"
196 :format-arguments
(list '*package
*
199 (type-of maybe-package
))
200 really-package
)))))))
202 ;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
203 ;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
204 ;;; actually need to reset the variable when it's silly, since even
205 ;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
206 ;;; in a state where it's hard to recover interactively.)
207 (defun sane-default-pathname-defaults ()
208 (let* ((dfd *default-pathname-defaults
*)
209 (dfd-dir (pathname-directory dfd
)))
210 ;; It's generally not good to use a relative pathname for
211 ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
212 ;; are defined by merging into a default pathname (which is,
213 ;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
214 (when (and (consp dfd-dir
)
215 (eql (first dfd-dir
) :relative
))
217 "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
218 '*default-pathname-defaults
*))
221 ;;; Give names to elements of a numeric sequence.
222 (defmacro defenum
((&key
(start 0) (step 1))
224 (declare (type integer start step
))
225 (let ((value (- start step
)))
227 ,@(mapcar (lambda (id)
230 (multiple-value-bind (sym docstring
)
232 (values (car id
) (cdr id
))
234 `(def!constant
,sym
,value
,@docstring
))))
237 ;;; a helper function for various macros which expect clauses of a
238 ;;; given length, etc.
240 ;;; Return true if X is a proper list whose length is between MIN and
242 (defun proper-list-of-length-p (x min
&optional
(max min
))
243 ;; FIXME: This implementation will hang on circular list
244 ;; structure. Since this is an error-checking utility, i.e. its
245 ;; job is to deal with screwed-up input, it'd be good style to fix
246 ;; it so that it can deal with circular list structure.
247 (cond ((minusp max
) nil
)
248 ((null x
) (zerop min
))
251 (proper-list-of-length-p (cdr x
)
258 (defun proper-list-p (x)
260 (return-from proper-list-p
(null x
)))
261 (let ((rabbit (cdr x
))
263 (flet ((pop-rabbit ()
264 (when (eql rabbit turtle
) ; circular
265 (return-from proper-list-p nil
))
267 (return-from proper-list-p
(null rabbit
)))
273 ;;; Helpers for defining error-signalling NOP's for "not supported
274 ;;; here" operations.
275 (defmacro define-unsupported-fun
(name &optional
276 (doc "Unsupported on this platform.")
278 "~S is unsupported on this platform ~
279 (OS, CPU, whatever)."
282 (declare (ignorable doc
))
283 `(defun ,name
(&rest args
)
286 (declare (ignore args
))
287 (error 'unsupported-operator
288 :format-control
,control
289 :format-arguments
(if ,controlp
',arguments
(list ',name
)))))
292 (defmacro awhen
(test &body body
)
296 (defmacro acond
(&rest clauses
)
299 (destructuring-bind ((test &body body
) &rest rest
) clauses
300 (let ((it (copy-symbol 'it
)))
303 ;; Just like COND - no body means return the tested value.
305 `(let ((it ,it
)) (declare (ignorable it
)) ,@body
)