44b51bb758c2858cdbbd32e9a6f7f6a1f63de1d5
[sbcl.git] / src / pcl / macros.lisp
1 ;;;; macros, global variable definitions, and other miscellaneous support stuff
2 ;;;; used by the rest of the PCL subsystem
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6
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
11 ;;;; information.
12
13 ;;;; copyright information from original PCL sources:
14 ;;;;
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
17 ;;;;
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
21 ;;;; control laws.
22 ;;;;
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
25 ;;;; specification.
26
27 (in-package "SB-PCL")
28 \f
29 (/show "starting pcl/macros.lisp")
30
31 (declaim (declaration
32           ;; These three nonstandard declarations seem to be used
33           ;; privately within PCL itself to pass information around,
34           ;; so we can't just delete them.
35           %class
36           %method-name
37           %method-lambda-list
38           ;; This declaration may also be used within PCL to pass
39           ;; information around, I'm not sure. -- WHN 2000-12-30
40           %variable-rebinding))
41
42 (/show "done with DECLAIM DECLARATION")
43
44 ;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
45 (eval-when (:compile-toplevel :load-toplevel :execute)
46
47 (defun extract-declarations (body &optional environment)
48   ;;(declare (values documentation declarations body))
49   (let (documentation
50         declarations
51         form)
52     (when (and (stringp (car body))
53                (cdr body))
54       (setq documentation (pop body)))
55     (block outer
56       (loop
57         (when (null body) (return-from outer nil))
58         (setq form (car body))
59         (when (block inner
60                 (loop (cond ((not (listp form))
61                              (return-from outer nil))
62                             ((eq (car form) 'declare)
63                              (return-from inner t))
64                             (t
65                              (multiple-value-bind (newform macrop)
66                                   (macroexpand-1 form environment)
67                                (if (or (not (eq newform form)) macrop)
68                                    (setq form newform)
69                                  (return-from outer nil)))))))
70           (pop body)
71           (dolist (declaration (cdr form))
72             (push declaration declarations)))))
73     (values documentation
74             (and declarations `((declare ,.(nreverse declarations))))
75             body)))
76 ) ; EVAL-WHEN
77
78 (/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS")
79
80 (defun get-declaration (name declarations &optional default)
81   (dolist (d declarations default)
82     (dolist (form (cdr d))
83       (when (and (consp form) (eq (car form) name))
84         (return-from get-declaration (cdr form))))))
85
86 (/show "pcl/macros.lisp 85")
87
88 (defmacro collecting-once (&key initial-value)
89    `(let* ((head ,initial-value)
90            (tail ,(and initial-value `(last head))))
91           (values #'(lambda (value)
92                            (if (null head)
93                                (setq head (setq tail (list value)))
94                                (unless (memq value head)
95                                  (setq tail
96                                        (cdr (rplacd tail (list value)))))))
97                   #'(lambda nil head))))
98
99 (/show "pcl/macros.lisp 98")
100
101 (defmacro doplist ((key val) plist &body body &environment env)
102   (multiple-value-bind (doc decls bod)
103       (extract-declarations body env)
104     (declare (ignore doc))
105     `(let ((.plist-tail. ,plist) ,key ,val)
106        ,@decls
107        (loop (when (null .plist-tail.) (return nil))
108              (setq ,key (pop .plist-tail.))
109              (when (null .plist-tail.)
110                (error "malformed plist, odd number of elements"))
111              (setq ,val (pop .plist-tail.))
112              (progn ,@bod)))))
113
114 (/show "pcl/macros.lisp 113")
115
116 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
117   `(let ((,var nil)
118          (.dolist-carefully. ,list))
119      (loop (when (null .dolist-carefully.) (return nil))
120            (if (consp .dolist-carefully.)
121                (progn
122                  (setq ,var (pop .dolist-carefully.))
123                  ,@body)
124                (,improper-list-handler)))))
125 \f
126 ;;;; FIND-CLASS
127 ;;;;
128 ;;;; This is documented in the CLOS specification. FIXME: Except that
129 ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
130 ;;;; PCL:FIND-CLASS, alas.
131
132 (/show "pcl/macros.lisp 132")
133
134 (defvar *find-class* (make-hash-table :test 'eq))
135
136 (defmacro find-class-cell-class (cell)
137   `(car ,cell))
138
139 (defmacro find-class-cell-predicate (cell)
140   `(cadr ,cell))
141
142 (defmacro find-class-cell-make-instance-function-keys (cell)
143   `(cddr ,cell))
144
145 (defmacro make-find-class-cell (class-name)
146   (declare (ignore class-name))
147   '(list* nil #'constantly-nil nil))
148
149 (defun find-class-cell (symbol &optional dont-create-p)
150   (or (gethash symbol *find-class*)
151       (unless dont-create-p
152         (unless (legal-class-name-p symbol)
153           (error "~S is not a legal class name." symbol))
154         (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
155
156 (/show "pcl/macros.lisp 157")
157
158 (defvar *create-classes-from-internal-structure-definitions-p* t)
159
160 (defun find-class-from-cell (symbol cell &optional (errorp t))
161   (or (find-class-cell-class cell)
162       (and *create-classes-from-internal-structure-definitions-p*
163            (structure-type-p symbol)
164            (find-structure-class symbol))
165       (cond ((null errorp) nil)
166             ((legal-class-name-p symbol)
167              (error "There is no class named ~S." symbol))
168             (t
169              (error "~S is not a legal class name." symbol)))))
170
171 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
172   (unless (find-class-cell-class cell)
173     (find-class-from-cell symbol cell errorp))
174   (find-class-cell-predicate cell))
175
176 (defun legal-class-name-p (x)
177   (and (symbolp x)
178        (not (keywordp x))))
179
180 (defun find-class (symbol &optional (errorp t) environment)
181   (declare (ignore environment))
182   (find-class-from-cell symbol
183                         (find-class-cell symbol errorp)
184                         errorp))
185
186 (defun find-class-predicate (symbol &optional (errorp t) environment)
187   (declare (ignore environment))
188   (find-class-predicate-from-cell symbol
189                                   (find-class-cell symbol errorp)
190                                   errorp))
191 \f
192 ;;; This DEFVAR was originally in defs.lisp, now moved here.
193 ;;;
194 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
195 ;;;
196 ;;; KLUDGE: This should probably become
197 ;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
198 (defvar *boot-state* nil)
199
200 (/show "pcl/macros.lisp 199")
201
202 ;;; Note that in SBCL as in CMU CL,
203 ;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
204 ;;; (Yes, this is a KLUDGE!)
205 (define-compiler-macro find-class (&whole form
206                                    symbol &optional (errorp t) environment)
207   (declare (ignore environment))
208   (if (and (constantp symbol)
209            (legal-class-name-p (eval symbol))
210            (constantp errorp)
211            (member *boot-state* '(braid complete)))
212       (let ((symbol (eval symbol))
213             (errorp (not (null (eval errorp))))
214             (class-cell (make-symbol "CLASS-CELL")))    
215         `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
216            (or (find-class-cell-class ,class-cell)
217                ,(if errorp
218                     `(find-class-from-cell ',symbol ,class-cell t)
219                     `(and (sb-kernel:class-cell-class
220                            ',(sb-kernel:find-class-cell symbol))
221                           (find-class-from-cell ',symbol ,class-cell nil))))))
222       form))
223
224 (defun (setf find-class) (new-value symbol)
225   (if (legal-class-name-p symbol)
226       (let ((cell (find-class-cell symbol)))
227         (setf (find-class-cell-class cell) new-value)
228         (when (or (eq *boot-state* 'complete)
229                   (eq *boot-state* 'braid))
230           (when (and new-value (class-wrapper new-value))
231             (setf (find-class-cell-predicate cell)
232                   (fdefinition (class-predicate-name new-value))))
233           (when (and new-value (not (forward-referenced-class-p new-value)))
234
235             (dolist (keys+aok (find-class-cell-make-instance-function-keys
236                                cell))
237               (update-initialize-info-internal
238                (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
239                'make-instance-function))))
240         new-value)
241       (error "~S is not a legal class name." symbol)))
242
243 (/show "pcl/macros.lisp 242")
244
245 (defun (setf find-class-predicate)
246        (new-value symbol)
247   (if (legal-class-name-p symbol)
248     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
249     (error "~S is not a legal class name." symbol)))
250
251 (defun find-wrapper (symbol)
252   (class-wrapper (find-class symbol)))
253
254 (defmacro gathering1 (gatherer &body body)
255   `(gathering ((.gathering1. ,gatherer))
256      (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
257        ,@body)))
258
259 (defmacro vectorizing (&key (size 0))
260   `(let* ((limit ,size)
261           (result (make-array limit))
262           (index 0))
263      (values #'(lambda (value)
264                  (if (= index limit)
265                      (error "vectorizing more elements than promised")
266                      (progn
267                        (setf (svref result index) value)
268                        (incf index)
269                        value)))
270              #'(lambda () result))))
271
272 (/show "pcl/macros.lisp 271")
273
274 ;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
275 ;;; iterate.lisp. These versions provide the extra :BY keyword which can
276 ;;; be used to specify the step function through the list.
277 (defmacro *list-elements (list &key (by #'cdr))
278   `(let ((tail ,list))
279      #'(lambda (finish)
280          (if (endp tail)
281              (funcall finish)
282              (prog1 (car tail)
283                     (setq tail (funcall ,by tail)))))))
284
285 (defmacro *list-tails (list &key (by #'cdr))
286    `(let ((tail ,list))
287       #'(lambda (finish)
288           (prog1 (if (endp tail)
289                      (funcall finish)
290                      tail)
291                  (setq tail (funcall ,by tail))))))
292
293 (defmacro function-funcall (form &rest args)
294   `(funcall (the function ,form) ,@args))
295
296 (defmacro function-apply (form &rest args)
297   `(apply (the function ,form) ,@args))
298
299 (/show "pcl/macros.lisp 299")
300 \f
301 (defun get-setf-fun-name (name)
302   `(setf ,name))
303
304 (defsetf slot-value set-slot-value)
305
306 (/show "finished with pcl/macros.lisp")