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