1 ;;;; macros, global variable definitions, and other miscellaneous support stuff
2 ;;;; used by the rest of the PCL subsystem
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from software originally released by Xerox
8 ;;;; Corporation. Copyright and release statements follow. Later modifications
9 ;;;; to the software are in the public domain and are provided with
10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
18 ;;;; Use and copying of this software and preparation of derivative works based
19 ;;;; upon this software are permitted. Any distribution of this software or
20 ;;;; derivative works must comply with all applicable United States export
23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
24 ;;;; warranty about the software, its performance or its conformity to any
30 ;; These three nonstandard declarations seem to be used
31 ;; privately within PCL itself to pass information around,
32 ;; so we can't just delete them.
36 ;; This declaration may also be used within PCL to pass
37 ;; information around, I'm not sure. -- WHN 2000-12-30
40 (defmacro name-get-fdefinition (name)
41 (sb-int:once-only ((name name))
42 `(if (symbolp ,name) ; take care of "setf <fun>"'s
43 (symbol-function ,name)
44 (fdefinition ,name))))
46 (defmacro name-set-fdefinition (name new-definition)
47 (sb-int:once-only ((name name))
48 `(if (symbolp ,name) ; take care of "setf <fun>"'s
49 (setf (symbol-function ,name) ,new-definition)
50 (setf (fdefinition ,name) ,new-definition))))
52 ;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
53 (macrolet ((def-constantly-fun (name constant-expr)
54 `(setf (symbol-function ',name)
55 (constantly ,constant-expr))))
56 (def-constantly-fun constantly-t t)
57 (def-constantly-fun constantly-nil nil)
58 (def-constantly-fun constantly-0 0))
60 ;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
61 (eval-when (:compile-toplevel :load-toplevel :execute)
62 (defun extract-declarations (body &optional environment)
63 ;;(declare (values documentation declarations body))
67 (when (and (stringp (car body))
69 (setq documentation (pop body)))
72 (when (null body) (return-from outer nil))
73 (setq form (car body))
75 (loop (cond ((not (listp form))
76 (return-from outer nil))
77 ((eq (car form) 'declare)
78 (return-from inner 't))
80 (multiple-value-bind (newform macrop)
81 (macroexpand-1 form environment)
82 (if (or (not (eq newform form)) macrop)
84 (return-from outer nil)))))))
86 (dolist (declaration (cdr form))
87 (push declaration declarations)))))
89 (and declarations `((declare ,.(nreverse declarations))))
93 (defun get-declaration (name declarations &optional default)
94 (dolist (d declarations default)
95 (dolist (form (cdr d))
96 (when (and (consp form) (eq (car form) name))
97 (return-from get-declaration (cdr form))))))
99 (defmacro collecting-once (&key initial-value)
100 `(let* ((head ,initial-value)
101 (tail ,(and initial-value `(last head))))
102 (values #'(lambda (value)
104 (setq head (setq tail (list value)))
105 (unless (memq value head)
107 (cdr (rplacd tail (list value)))))))
108 #'(lambda nil head))))
110 (defmacro doplist ((key val) plist &body body &environment env)
111 (multiple-value-bind (doc decls bod)
112 (extract-declarations body env)
113 (declare (ignore doc))
114 `(let ((.plist-tail. ,plist) ,key ,val)
116 (loop (when (null .plist-tail.) (return nil))
117 (setq ,key (pop .plist-tail.))
118 (when (null .plist-tail.)
119 (error "malformed plist, odd number of elements"))
120 (setq ,val (pop .plist-tail.))
123 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
125 (.dolist-carefully. ,list))
126 (loop (when (null .dolist-carefully.) (return nil))
127 (if (consp .dolist-carefully.)
129 (setq ,var (pop .dolist-carefully.))
131 (,improper-list-handler)))))
135 ;;;; This is documented in the CLOS specification. FIXME: Except that
136 ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
137 ;;;; PCL:FIND-CLASS, alas.
139 (defvar *find-class* (make-hash-table :test 'eq))
141 (defmacro find-class-cell-class (cell)
144 (defmacro find-class-cell-predicate (cell)
147 (defmacro find-class-cell-make-instance-function-keys (cell)
150 (defmacro make-find-class-cell (class-name)
151 (declare (ignore class-name))
152 '(list* nil #'constantly-nil nil))
154 (defun find-class-cell (symbol &optional dont-create-p)
155 (or (gethash symbol *find-class*)
156 (unless dont-create-p
157 (unless (legal-class-name-p symbol)
158 (error "~S is not a legal class name." symbol))
159 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
161 (defvar *create-classes-from-internal-structure-definitions-p* t)
163 (defun find-class-from-cell (symbol cell &optional (errorp t))
164 (or (find-class-cell-class cell)
165 (and *create-classes-from-internal-structure-definitions-p*
166 (structure-type-p symbol)
167 (find-structure-class symbol))
168 (cond ((null errorp) nil)
169 ((legal-class-name-p symbol)
170 (error "There is no class named ~S." symbol))
172 (error "~S is not a legal class name." symbol)))))
174 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
175 (unless (find-class-cell-class cell)
176 (find-class-from-cell symbol cell errorp))
177 (find-class-cell-predicate cell))
179 (defun legal-class-name-p (x)
183 (defun find-class (symbol &optional (errorp t) environment)
184 (declare (ignore environment))
185 (find-class-from-cell symbol
186 (find-class-cell symbol errorp)
189 (defun find-class-predicate (symbol &optional (errorp t) environment)
190 (declare (ignore environment))
191 (find-class-predicate-from-cell symbol
192 (find-class-cell symbol errorp)
195 ;;; This DEFVAR was originally in defs.lisp, now moved here.
197 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
199 ;;; KLUDGE: This should probably become
200 ;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
201 (defvar *boot-state* nil)
203 ;;; Note that in SBCL as in CMU CL,
204 ;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
205 ;;; (Yes, this is a KLUDGE!)
206 (define-compiler-macro find-class (&whole form
207 symbol &optional (errorp t) environment)
208 (declare (ignore environment))
209 (if (and (constantp symbol)
210 (legal-class-name-p (eval symbol))
212 (member *boot-state* '(braid complete)))
213 (let ((symbol (eval symbol))
214 (errorp (not (null (eval errorp))))
215 (class-cell (make-symbol "CLASS-CELL")))
216 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
217 (or (find-class-cell-class ,class-cell)
219 `(find-class-from-cell ',symbol ,class-cell t)
220 `(and (sb-kernel:class-cell-class
221 ',(sb-kernel:find-class-cell symbol))
222 (find-class-from-cell ',symbol ,class-cell nil))))))
225 (defun (setf find-class) (new-value symbol)
226 (if (legal-class-name-p symbol)
227 (let ((cell (find-class-cell symbol)))
228 (setf (find-class-cell-class cell) new-value)
229 (when (or (eq *boot-state* 'complete)
230 (eq *boot-state* 'braid))
231 (when (and new-value (class-wrapper new-value))
232 (setf (find-class-cell-predicate cell)
233 (name-get-fdefinition (class-predicate-name new-value))))
234 (when (and new-value (not (forward-referenced-class-p new-value)))
236 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
237 (update-initialize-info-internal
238 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
239 'make-instance-function))))
241 (error "~S is not a legal class name." symbol)))
243 (defun (setf find-class-predicate)
245 (if (legal-class-name-p symbol)
246 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
247 (error "~S is not a legal class name." symbol)))
249 (defun find-wrapper (symbol)
250 (class-wrapper (find-class symbol)))
252 (defmacro gathering1 (gatherer &body body)
253 `(gathering ((.gathering1. ,gatherer))
254 (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
257 (defmacro vectorizing (&key (size 0))
258 `(let* ((limit ,size)
259 (result (make-array limit))
261 (values #'(lambda (value)
263 (error "vectorizing more elements than promised")
265 (setf (svref result index) value)
268 #'(lambda () result))))
270 ;;; These are augmented definitions of list-elements and list-tails from
271 ;;; iterate.lisp. These versions provide the extra :by keyword which can
272 ;;; be used to specify the step function through the list.
273 (defmacro *list-elements (list &key (by #'cdr))
279 (setq tail (funcall ,by tail)))))))
281 (defmacro *list-tails (list &key (by #'cdr))
284 (prog1 (if (endp tail)
287 (setq tail (funcall ,by tail))))))
289 (defmacro function-funcall (form &rest args)
290 `(funcall (the function ,form) ,@args))
292 (defmacro function-apply (form &rest args)
293 `(apply (the function ,form) ,@args))
296 (defun get-setf-function-name (name)
299 (defsetf slot-value set-slot-value)