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