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 ;; Define "exchanged subtract" So that DECF on a symbol requires no LET binding:
32 ;; (DECF I (EXPR)) -> (SETQ I (XSUBTRACT (EXPR) I))
33 ;; which meets the CLHS 5.1.3 requirement to eval (EXPR) prior to reading
34 ;; the old value of I. Formerly in 'setf' but too late to avoid full calls.
35 (declaim (inline xsubtract
))
36 (defun xsubtract (a b
) (- b a
))
40 ;;; Automate an idiom often found in macros:
41 ;;; (LET ((FOO (GENSYM "FOO"))
42 ;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
45 ;;; "Good notation eliminates thought." -- Eric Siggia
47 ;;; Incidentally, this is essentially the same operator which
48 ;;; _On Lisp_ calls WITH-GENSYMS.
49 (defmacro with-unique-names
(symbols &body body
)
50 (declare (notinline every
)) ; because we can't inline ALPHA-CHAR-P
51 `(let ,(mapcar (lambda (symbol)
52 (let* ((symbol-name (symbol-name symbol
))
53 (stem (if (every #'alpha-char-p symbol-name
)
55 (concatenate 'string symbol-name
"-"))))
56 `(,symbol
(sb!xc
:gensym
,stem
))))
60 ;;; Return a list of N gensyms. (This is a common suboperation in
61 ;;; macros and other code-manipulating code.)
62 (declaim (ftype (function (unsigned-byte &optional t
) (values list
&optional
))
64 (defun make-gensym-list (n &optional name
)
65 (let ((arg (if name
(string name
) "G")))
66 (loop repeat n collect
(sb!xc
:gensym arg
))))
70 ;;; Lots of code wants to get to the KEYWORD package or the
71 ;;; COMMON-LISP package without a lot of fuss, so we cache them in
72 ;;; variables on the host, or use L-T-V forms on the target.
73 (macrolet ((def-it (sym expr
)
75 `(progn (declaim (type package
,sym
))
78 ;; We don't need to declaim the type. FIND-PACKAGE
79 ;; returns a package, and L-T-V propagates types.
80 ;; It's ugly how it achieves that, but it's a separate concern.
81 `(define-symbol-macro ,sym
(load-time-value ,expr t
))))
82 (def-it *cl-package
* (find-package "COMMON-LISP"))
83 (def-it *keyword-package
* (find-package "KEYWORD")))
85 (declaim (inline singleton-p
))
86 (defun singleton-p (list)
87 (and (listp list
) (null (rest list
)) list
))
89 ;;; Concatenate together the names of some strings and symbols,
90 ;;; producing a symbol in the current package.
91 (defun symbolicate (&rest things
)
92 (declare (dynamic-extent things
))
95 (if (singleton-p things
)
96 (string (first things
))
97 (let* ((length (reduce #'+ things
98 :key
(lambda (x) (length (string x
)))))
99 (name (make-array length
:element-type
'character
))
101 (dolist (thing things name
)
102 (let ((x (string thing
)))
103 (replace name x
:start1 index
)
104 (incf index
(length x
)))))))))
108 (sb!xc
:gensym
(symbol-name x
))
111 ;;; like SYMBOLICATE, but producing keywords
112 (defun keywordicate (&rest things
)
113 (let ((*package
* *keyword-package
*))
114 (apply #'symbolicate things
)))
116 ;;; Access *PACKAGE* in a way which lets us recover when someone has
117 ;;; done something silly like (SETF *PACKAGE* :CL-USER) in unsafe code.
118 ;;; (Such an assignment is undefined behavior, so it's sort of reasonable for
119 ;;; it to cause the system to go totally insane afterwards, but it's a
120 ;;; fairly easy mistake to make, so let's try to recover gracefully instead.)
121 (defun sane-package ()
122 ;; Perhaps it's possible for *PACKAGE* to be set to a non-package in some
123 ;; host Lisp, but in SBCL it isn't, and the PACKAGEP test below would be
124 ;; elided unless forced to be NOTINLINE.
125 (declare (notinline packagep
))
126 (let* ((maybe-package *package
*)
127 (packagep (packagep maybe-package
)))
128 ;; And if we don't also always check for deleted packages - as was true
129 ;; when the "#+sb-xc-host" reader condition was absent - then half of the
130 ;; COND becomes unreachable, making this function merely return *PACKAGE*
131 ;; in the cross-compiler, producing a code deletion note.
133 ;; For good measure, we also catch the problem of
134 ;; *PACKAGE* being bound to a deleted package.
135 ;; Technically, this is not undefined behavior in itself,
136 ;; but it will immediately lead to undefined to behavior,
137 ;; since almost any operation on a deleted package is
139 (package-%name maybe-package
))
142 ;; We're in the undefined behavior zone. First, munge the
143 ;; system back into a defined state.
144 (let ((really-package
145 (load-time-value (find-package :cl-user
) t
)))
146 (setf *package
* really-package
)
148 (error 'simple-type-error
150 :expected-type
'(and package
(satisfies package-name
))
152 "~@<~S can't be a ~A: ~2I~_It has been reset to ~S.~:>"
153 :format-arguments
(list '*package
*
156 (type-of maybe-package
))
157 really-package
)))))))
159 ;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
160 ;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
161 ;;; actually need to reset the variable when it's silly, since even
162 ;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
163 ;;; in a state where it's hard to recover interactively.)
164 (defun sane-default-pathname-defaults ()
165 (let* ((dfd *default-pathname-defaults
*)
166 (dfd-dir (pathname-directory dfd
)))
167 ;; It's generally not good to use a relative pathname for
168 ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
169 ;; are defined by merging into a default pathname (which is,
170 ;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
171 (when (and (consp dfd-dir
)
172 (eql (first dfd-dir
) :relative
))
174 "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
175 '*default-pathname-defaults
*))
178 ;;; Give names to elements of a numeric sequence.
179 (defmacro defenum
((&key
(start 0) (step 1))
181 (declare (type integer start step
))
182 (let ((value (- start step
)))
184 ,@(mapcar (lambda (id)
187 (multiple-value-bind (sym docstring
)
189 (values (car id
) (cdr id
))
191 `(def!constant
,sym
,value
,@docstring
))))
194 ;;; a helper function for various macros which expect clauses of a
195 ;;; given length, etc.
197 ;;; Return true if X is a proper list whose length is between MIN and
199 (defun proper-list-of-length-p (x min
&optional
(max min
))
200 ;; FIXME: This implementation will hang on circular list
201 ;; structure. Since this is an error-checking utility, i.e. its
202 ;; job is to deal with screwed-up input, it'd be good style to fix
203 ;; it so that it can deal with circular list structure.
204 (cond ((minusp max
) nil
)
205 ((null x
) (zerop min
))
208 (proper-list-of-length-p (cdr x
)
215 (defun proper-list-p (x)
217 (return-from proper-list-p
(null x
)))
218 (let ((rabbit (cdr x
))
220 (flet ((pop-rabbit ()
221 (when (eql rabbit turtle
) ; circular
222 (return-from proper-list-p nil
))
224 (return-from proper-list-p
(null rabbit
)))
230 ;;; Helpers for defining error-signalling NOP's for "not supported
231 ;;; here" operations.
232 (defmacro define-unsupported-fun
(name &optional
233 (doc "Unsupported on this platform.")
235 "~S is unsupported on this platform ~
236 (OS, CPU, whatever)."
239 (declare (ignorable doc
))
240 `(defun ,name
(&rest args
)
243 (declare (ignore args
))
244 (error 'unsupported-operator
245 :format-control
,control
246 :format-arguments
(if ,controlp
',arguments
(list ',name
)))))
249 (defmacro awhen
(test &body body
)
253 (defmacro acond
(&rest clauses
)
256 (destructuring-bind ((test &body body
) &rest rest
) clauses
257 (let ((it (copy-symbol 'it
)))
260 ;; Just like COND - no body means return the tested value.
262 `(let ((it ,it
)) (declare (ignorable it
)) ,@body
)
266 ;; This is not an 'extension', but is needed super early, so ....
267 (defmacro sb
!xc
:defconstant
(name value
&optional
(doc nil docp
))
269 "Define a global constant, saying that the value is constant and may be
270 compiled into code. If the variable already has a value, and this is not
271 EQL to the new value, the code is not portable (undefined behavior). The
272 third argument is an optional documentation string for the variable."
273 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
274 (sb!c
::%defconstant
',name
,value
(sb!c
:source-location
)
275 ,@(and docp
`(',doc
)))))