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
29(declaim (declaration
30          ;; These nonstandard declarations seem to be used privately
31          ;; within PCL itself to pass information around, so we can't
32          ;; just delete them.
33          %class
34          ;; This declaration may also be used within PCL to pass
35          ;; information around, I'm not sure. -- WHN 2000-12-30
36          %variable-rebinding))
37
38(defun get-declaration (name declarations &optional default)
39  (dolist (d declarations default)
40    (dolist (form (cdr d))
41      (when (and (consp form) (eq (car form) name))
42        (return-from get-declaration (cdr form))))))
43
44(defmacro dolist-carefully ((var list improper-list-handler) &body body)
45  `(let ((,var nil)
46         (.dolist-carefully. ,list))
47     (loop (when (null .dolist-carefully.) (return nil))
48           (if (consp .dolist-carefully.)
49               (progn
50                 (setq ,var (pop .dolist-carefully.))
51                 ,@body)
52               (,improper-list-handler)))))
53
54;;;; FIND-CLASS
55;;;;
56;;;; This is documented in the CLOS specification.
57
58(define-condition illegal-class-name-error (error)
59  ((name :initarg :name :reader illegal-class-name-error-name))
60  (:default-initargs :name (missing-arg))
61  (:report (lambda (condition stream)
62             (format stream "~@<~S is not a legal class name.~@:>"
63                     (illegal-class-name-error-name condition)))))
64
65(declaim (inline legal-class-name-p check-class-name))
66(defun legal-class-name-p (thing)
67  (symbolp thing))
68
69(defun check-class-name (thing &optional (allow-nil t))
70  ;; Apparently, FIND-CLASS and (SETF FIND-CLASS) accept any symbol,
71  ;; but DEFCLASS only accepts non-NIL symbols.
72  (if (or (not (legal-class-name-p thing))
73          (and (null thing) (not allow-nil)))
74      (error 'illegal-class-name-error :name thing)
75      thing))
76
77(define-condition class-not-found-error (sb-kernel::cell-error)
78  ((sb-kernel::name :type (satisfies legal-class-name-p)))
79  (:report (lambda (condition stream)
80             (format stream "~@<There is no class named ~
81                             ~/sb-impl:print-symbol-with-prefix/.~@:>"
82                     (sb-kernel::cell-error-name condition)))))
83
84(eval-when (:compile-toplevel :load-toplevel :execute)
85  (defvar *create-classes-from-internal-structure-definitions-p* t))
86(declaim (always-bound *create-classes-from-internal-structure-definitions-p*))
87
88(declaim (ftype function ensure-non-standard-class))
89(defun find-class-from-cell (symbol cell &optional (errorp t))
90  (or (when cell
91        (or (classoid-cell-pcl-class cell)
92            (when *create-classes-from-internal-structure-definitions-p*
93              (let ((classoid (classoid-cell-classoid cell)))
94                (when (and classoid
95                           (or (condition-classoid-p classoid)
96                               (defstruct-classoid-p classoid)))
97                  (ensure-non-standard-class symbol classoid))))))
98      (when errorp
99        (check-class-name symbol)
100        (error 'class-not-found-error :name symbol))))
101
102(defun find-class (symbol &optional (errorp t) environment)
103  (declare (ignore environment) (explicit-check))
104  (find-class-from-cell symbol
105                        (find-classoid-cell symbol)
106                        errorp))
107
108
109(define-compiler-macro find-class (&whole form
110                                   symbol &optional (errorp t) environment)
111  (declare (ignore environment))
112  (if (and (constantp symbol)
113           (legal-class-name-p (setf symbol (constant-form-value symbol)))
114           (constantp errorp)
115           (member **boot-state** '(braid complete)))
116      (let ((errorp (not (null (constant-form-value errorp))))
117            (cell (make-symbol "CLASSOID-CELL")))
118        `(let ((,cell ,(find-classoid-cell symbol :create t)))
119           (or (classoid-cell-pcl-class ,cell)
120               ,(if errorp
121                    `(find-class-from-cell ',symbol ,cell)
122                    `(when (classoid-cell-classoid ,cell)
123                       (find-class-from-cell ',symbol ,cell nil))))))
124      form))
125
126(declaim (ftype function update-ctors))
127(defun (setf find-class) (new-value name &optional errorp environment)
128  (declare (ignore errorp environment))
129  (check-class-name name)
130  (with-single-package-locked-error
131      (:symbol name "Using ~A as the class-name argument in ~
132                     (SETF FIND-CLASS)"))
133  (with-world-lock ()
134    (let ((cell (find-classoid-cell name :create new-value)))
135      (cond (new-value
136             (setf (classoid-cell-pcl-class cell) new-value)
137             (when (eq **boot-state** 'complete)
138               (let ((classoid (class-classoid new-value)))
139                 (setf (find-classoid name) classoid))))
140            (cell
141             (%clear-classoid name cell)))
142      (when (or (eq **boot-state** 'complete)
143                (eq **boot-state** 'braid))
144        (update-ctors 'setf-find-class :class new-value :name name))
145      new-value)))
146
147(flet ((call-gf (gf-nameize action object slot-name env &optional newval)
148         (aver (constantp slot-name env))
149         (let* ((slot-name (constant-form-value slot-name env))
150                (gf-name (funcall gf-nameize slot-name)))
151           `(funcall (load-time-value
152                      (progn (ensure-accessor ',action ',gf-name ',slot-name)
153                             (fdefinition ',gf-name)) t)
154                     ,@newval ,object))))
155  (defmacro accessor-slot-boundp (object slot-name &environment env)
156    (call-gf 'slot-boundp-name 'boundp object slot-name env))
157
158  (defmacro accessor-slot-value (object slot-name &environment env)
159    `(truly-the (values t &optional)
160                ,(call-gf 'slot-reader-name 'reader object slot-name env)))
161
162  (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
163    ;; Expand NEW-VALUE before deciding not to bind a temp var for OBJECT,
164    ;; which should be eval'd first. We skip the binding if either new-value
165    ;; is constant or a plain variable. This is still subtly wrong if NEW-VALUE
166    ;; is a special, because we'll read it more than once.
167    (setq new-value (%macroexpand new-value env))
168    (let ((bind-object (unless (or (constantp new-value env) (atom new-value))
169                         (let* ((object-var (gensym))
170                                (bind `((,object-var ,object))))
171                           (setf object object-var)
172                           bind)))
173          ;; What's going on by not assuming that #'(SETF x) returns NEW-VALUE?
174          ;; It seems wrong to return anything other than what the SETF fun
175          ;; yielded. By analogy, when the SETF macro changes (SETF (F x) v)
176          ;; into (funcall #'(setf F) ...), it does not insert any code to
177          ;; enforce V as the overall value. So we do we do that here???
178          (form `(let ((.new-value. ,new-value))
179                   ,(call-gf 'slot-writer-name 'writer object slot-name env
180                             '(.new-value.))
181                   .new-value.)))
182      (if bind-object
183          `(let ,bind-object ,form)
184          form))))
185
186(defmacro function-funcall (form &rest args)
187  `(funcall (the function ,form) ,@args))
188
189(defmacro function-apply (form &rest args)
190  `(apply (the function ,form) ,@args))
191
192(defun get-setf-fun-name (name)
193  `(setf ,name))
194