1;;;; This software is part of the SBCL system. See the README file for 2;;;; more information. 3 4;;;; This software is derived from software originally released by Xerox 5;;;; Corporation. Copyright and release statements follow. Later modifications 6;;;; to the software are in the public domain and are provided with 7;;;; absolutely no warranty. See the COPYING and CREDITS files for more 8;;;; information. 9 10;;;; copyright information from original PCL sources: 11;;;; 12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 13;;;; All rights reserved. 14;;;; 15;;;; Use and copying of this software and preparation of derivative works based 16;;;; upon this software are permitted. Any distribution of this software or 17;;;; derivative works must comply with all applicable United States export 18;;;; control laws. 19;;;; 20;;;; This software is made available AS IS, and Xerox Corporation makes no 21;;;; warranty about the software, its performance or its conformity to any 22;;;; specification. 23 24(in-package "SB-PCL") 25 26;;;; DEFCLASS macro and close personal friends 27 28;;; state for the current DEFCLASS expansion 29(defvar *initfunctions-for-this-defclass*) 30(defvar *readers-for-this-defclass*) 31(defvar *writers-for-this-defclass*) 32(defvar *slot-names-for-this-defclass*) 33 34;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is 35;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until 36;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition 37;;; which simply collects all class definitions up, when the metabraid 38;;; is initialized it is done from those class definitions. 39;;; 40;;; After the metabraid has been setup, and the protocol for defining 41;;; classes has been defined, the real definition of LOAD-DEFCLASS is 42;;; installed by the file std-class.lisp 43(defmacro defclass (&environment env name direct-superclasses direct-slots &rest options) 44 (check-class-name name nil) 45 (let (*initfunctions-for-this-defclass* 46 *readers-for-this-defclass* ;Truly a crock, but we got 47 *writers-for-this-defclass* ;to have it to live nicely. 48 *slot-names-for-this-defclass*) 49 ;; FIXME: It would be nice to collect all errors from the 50 ;; expansion of a defclass and signal them in a single go. 51 (multiple-value-bind (metaclass canonical-options) 52 (canonize-defclass-options name options) 53 ;; Check deprecation status of direct superclasses and 54 ;; metaclass. 55 (mapc #'sb-int:check-deprecated-type direct-superclasses) 56 (sb-int:check-deprecated-type metaclass) 57 (let ((canonical-slots (canonize-defclass-slots name direct-slots env)) 58 ;; DEFSTRUCT-P should be true if the class is defined 59 ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT 60 ;; is compiled for the class. 61 (defstruct-p (and (eq **boot-state** 'complete) 62 (let ((mclass (find-class metaclass nil))) 63 (and mclass 64 (*subtypep 65 mclass 66 *the-class-structure-class*)))))) 67 (let* ((defclass-form 68 `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*) 69 (load-defclass ',name 70 ',metaclass 71 ',direct-superclasses 72 (list ,@canonical-slots) 73 (list ,@(apply #'append 74 (when defstruct-p 75 '(:from-defclass-p t)) 76 canonical-options)) 77 ',*readers-for-this-defclass* 78 ',*writers-for-this-defclass* 79 ',*slot-names-for-this-defclass* 80 (sb-c:source-location) 81 ,@(and (safe-code-p env) 82 '(t)))))) 83 (if defstruct-p 84 (progn 85 ;; FIXME: (YUK!) Why do we do this? Because in order 86 ;; to make the defstruct form, we need to know what 87 ;; the accessors for the slots are, so we need already 88 ;; to have hooked into the CLOS machinery. 89 ;; 90 ;; There may be a better way to do this: it would 91 ;; involve knowing enough about PCL to ask "what will 92 ;; my slot names and accessors be"; failing this, we 93 ;; currently just evaluate the whole kaboodle, and 94 ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07 95 (eval defclass-form) 96 (let* ((include (or (and direct-superclasses 97 (find-class (car direct-superclasses) nil)) 98 (and (not (eq name 'structure-object)) 99 *the-class-structure-object*))) 100 (defstruct-form (make-structure-class-defstruct-form 101 name (class-direct-slots (find-class name)) 102 include))) 103 `(progn 104 (eval-when (:compile-toplevel :load-toplevel :execute) 105 ,defstruct-form) ; really compile the defstruct-form 106 (eval-when (:compile-toplevel :load-toplevel :execute) 107 ,defclass-form)))) 108 `(progn 109 ;; By telling the type system at compile time about 110 ;; the existence of a class named NAME, we can avoid 111 ;; various bogus warnings about "type isn't defined yet" 112 ;; for code elsewhere in the same file which uses 113 ;; the name of the type. 114 ;; 115 ;; We only need to do this at compile time, because 116 ;; at load and execute time we write the actual 117 ;; full-blown class, so the "a class of this name is 118 ;; coming" note we write here would be irrelevant. 119 (eval-when (:compile-toplevel) 120 (sb-kernel::%compiler-defclass 121 ',name 122 ',*readers-for-this-defclass* 123 ',*writers-for-this-defclass* 124 ',*slot-names-for-this-defclass*)) 125 ,defclass-form))))))) 126 127(defun canonize-defclass-options (class-name options) 128 (maplist (lambda (sublist) 129 (let ((option-name (first (pop sublist)))) 130 (when (member option-name sublist :key #'first :test #'eq) 131 (error 'simple-program-error 132 :format-control "Multiple ~S options in DEFCLASS ~S." 133 :format-arguments (list option-name class-name))))) 134 options) 135 (let (metaclass 136 default-initargs 137 documentation 138 canonized-options) 139 (dolist (option options) 140 (unless (listp option) 141 (error "~S is not a legal defclass option." option)) 142 (case (first option) 143 (:metaclass 144 (let ((maybe-metaclass (second option))) 145 (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass)) 146 (error 'simple-program-error 147 :format-control "~@<The value of the :metaclass option (~S) ~ 148 is not a legal class name.~:@>" 149 :format-arguments (list maybe-metaclass))) 150 (setf metaclass maybe-metaclass))) 151 (:default-initargs 152 (let (initargs arg-names) 153 (doplist (key val) (cdr option) 154 (when (member key arg-names :test #'eq) 155 (error 'simple-program-error 156 :format-control "~@<Duplicate initialization argument ~ 157 name ~S in :DEFAULT-INITARGS of ~ 158 DEFCLASS ~S.~:>" 159 :format-arguments (list key class-name))) 160 (push key arg-names) 161 (push ``(,',key ,',val ,,(make-initfunction val)) initargs)) 162 (setf default-initargs t) 163 (push `(:direct-default-initargs (list ,@(nreverse initargs))) 164 canonized-options))) 165 (:documentation 166 (unless (stringp (second option)) 167 (error "~S is not a legal :documentation value" (second option))) 168 (setf documentation t) 169 (push `(:documentation ,(second option)) canonized-options)) 170 (otherwise 171 (push `(',(car option) ',(cdr option)) canonized-options)))) 172 (unless default-initargs 173 (push '(:direct-default-initargs nil) canonized-options)) 174 (values (or metaclass 'standard-class) (nreverse canonized-options)))) 175 176(defun canonize-defclass-slots (class-name slots env) 177 (let (canonized-specs) 178 (dolist (spec slots) 179 (let ((location (or (and (boundp 'sb-c::*current-path*) 180 (boundp 'sb-c::*source-paths*) 181 (let ((sb-c::*current-path* 182 (or (sb-c::get-source-path spec) 183 sb-c::*current-path*))) 184 (sb-c::make-definition-source-location))) 185 (sb-c::make-definition-source-location)))) 186 (when (atom spec) 187 (setf spec (list spec))) 188 (when (and (cdr spec) (null (cddr spec))) 189 (error 'simple-program-error 190 :format-control "~@<in DEFCLASS ~S, the slot specification ~S ~ 191 is invalid; the probable intended meaning may ~ 192 be achieved by specifiying ~S instead.~:>" 193 :format-arguments (list class-name spec 194 `(,(car spec) :initform ,(cadr spec))))) 195 (let* ((name (car spec)) 196 (plist (cdr spec)) 197 (readers ()) 198 (writers ()) 199 (initargs ()) 200 (others ()) 201 (unsupplied (list nil)) 202 (type t) 203 (initform unsupplied)) 204 (check-slot-name-for-defclass name class-name env) 205 (push name *slot-names-for-this-defclass*) 206 (flet ((note-reader (x) 207 (unless (symbolp x) 208 (error 'simple-program-error 209 :format-control "Slot reader name ~S for slot ~S in ~ 210 DEFCLASS ~S is not a symbol." 211 :format-arguments (list x name class-name))) 212 (push x readers) 213 (push x *readers-for-this-defclass*)) 214 (note-writer (x) 215 (push x writers) 216 (push x *writers-for-this-defclass*))) 217 (doplist (key val) plist 218 (case key 219 (:accessor (note-reader val) (note-writer `(setf ,val))) 220 (:reader (note-reader val)) 221 (:writer (note-writer val)) 222 (:initarg 223 (unless (symbolp val) 224 (error 'simple-program-error 225 :format-control "Slot initarg name ~S for slot ~S in ~ 226 DEFCLASS ~S is not a symbol." 227 :format-arguments (list val name class-name))) 228 (push val initargs)) 229 (otherwise 230 (when (member key '(:initform :allocation :type :documentation)) 231 (when (eq key :initform) 232 (setf initform val)) 233 (when (eq key :type) 234 (setf type val)) 235 (when (get-properties others (list key)) 236 (error 'simple-program-error 237 :format-control "Duplicate slot option ~S for slot ~ 238 ~S in DEFCLASS ~S." 239 :format-arguments (list key name class-name)))) 240 ;; For non-standard options multiple entries go in a list 241 (push val (getf others key)))))) 242 ;; Unwrap singleton lists (AMOP 5.4.2) 243 (do ((head others (cddr head))) 244 ((null head)) 245 (unless (cdr (second head)) 246 (setf (second head) (car (second head))))) 247 (let ((canon `(:name ',name :readers ',readers :writers ',writers 248 :initargs ',initargs 'source ,location ',others))) 249 (push (if (eq initform unsupplied) 250 `(list* ,@canon) 251 `(list* :initfunction ,(make-initfunction initform) 252 ,@canon)) 253 canonized-specs))))) 254 (nreverse canonized-specs))) 255 256 257(defun check-slot-name-for-defclass (name class-name env) 258 (flet ((slot-name-illegal (reason) 259 (error 'simple-program-error 260 :format-control "~@<In DEFCLASS ~S, the slot name ~S ~ 261 is ~A.~@:>" 262 :format-arguments (list class-name name reason)))) 263 (cond ((not (symbolp name)) 264 (slot-name-illegal "not a symbol")) 265 ((keywordp name) 266 (slot-name-illegal "a keyword")) 267 ((constantp name env) 268 (slot-name-illegal "a constant")) 269 ((member name *slot-names-for-this-defclass* :test #'eq) 270 (error 'simple-program-error 271 :format-control "Multiple slots named ~S in DEFCLASS ~S." 272 :format-arguments (list name class-name)))))) 273 274(defun make-initfunction (initform) 275 (cond ((or (eq initform t) 276 (equal initform ''t)) 277 '(function constantly-t)) 278 ((or (eq initform nil) 279 (equal initform ''nil)) 280 '(function constantly-nil)) 281 ((or (eql initform 0) 282 (equal initform ''0)) 283 '(function constantly-0)) 284 (t 285 (let ((entry (assoc initform *initfunctions-for-this-defclass* 286 :test #'equal))) 287 (unless entry 288 (setq entry (list initform 289 (gensym) 290 `(function (lambda () 291 (declare (optimize 292 (sb-c:store-coverage-data 0))) 293 ,initform)))) 294 (push entry *initfunctions-for-this-defclass*)) 295 (cadr entry))))) 296 297 298;;; This is the early definition of LOAD-DEFCLASS. It just collects up 299;;; all the class definitions in a list. Later, in braid1.lisp, these 300;;; are actually defined. 301 302;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION. 303(defparameter *early-class-definitions* ()) 304 305(defun early-class-definition (class-name) 306 (or (find class-name *early-class-definitions* :key #'ecd-class-name) 307 (error "~S is not a class in *early-class-definitions*." class-name))) 308 309(defun make-early-class-definition 310 (name source-location metaclass 311 superclass-names canonical-slots other-initargs) 312 (list 'early-class-definition 313 name source-location metaclass 314 superclass-names canonical-slots other-initargs)) 315 316(defun ecd-class-name (ecd) (nth 1 ecd)) 317(defun ecd-source-location (ecd) (nth 2 ecd)) 318(defun ecd-metaclass (ecd) (nth 3 ecd)) 319(defun ecd-superclass-names (ecd) (nth 4 ecd)) 320(defun ecd-canonical-slots (ecd) (nth 5 ecd)) 321(defun ecd-other-initargs (ecd) (nth 6 ecd)) 322 323(defvar *early-class-slots* nil) 324 325(defun canonical-slot-name (canonical-slot) 326 (getf canonical-slot :name)) 327 328(defun early-class-slots (class-name) 329 (cdr (or (assoc class-name *early-class-slots*) 330 (let ((a (cons class-name 331 (mapcar #'canonical-slot-name 332 (early-collect-inheritance class-name))))) 333 (push a *early-class-slots*) 334 a)))) 335 336(defun early-class-size (class-name) 337 (length (early-class-slots class-name))) 338 339(defun early-collect-inheritance (class-name) 340 ;;(declare (values slots cpl default-initargs direct-subclasses)) 341 (let ((cpl (early-collect-cpl class-name))) 342 (values (early-collect-slots cpl) 343 cpl 344 (early-collect-default-initargs cpl) 345 (let (collect) 346 (dolist (definition *early-class-definitions*) 347 (when (memq class-name (ecd-superclass-names definition)) 348 (push (ecd-class-name definition) collect))) 349 (nreverse collect))))) 350 351(defun early-collect-slots (cpl) 352 (let* ((definitions (mapcar #'early-class-definition cpl)) 353 (super-slots (mapcar #'ecd-canonical-slots definitions)) 354 (slots (apply #'append (reverse super-slots)))) 355 (dolist (s1 slots) 356 (let ((name1 (canonical-slot-name s1))) 357 (dolist (s2 (cdr (memq s1 slots))) 358 (when (eq name1 (canonical-slot-name s2)) 359 (error "More than one early class defines a slot with the~%~ 360 name ~S. This can't work because the bootstrap~%~ 361 object system doesn't know how to compute effective~%~ 362 slots." 363 name1))))) 364 slots)) 365 366(defun early-collect-cpl (class-name) 367 (labels ((walk (c) 368 (let* ((definition (early-class-definition c)) 369 (supers (ecd-superclass-names definition))) 370 (cons c 371 (apply #'append (mapcar #'early-collect-cpl supers)))))) 372 (remove-duplicates (walk class-name) :from-end nil :test #'eq))) 373 374(defun early-collect-default-initargs (cpl) 375 (let ((default-initargs ())) 376 (dolist (class-name cpl) 377 (let* ((definition (early-class-definition class-name)) 378 (others (ecd-other-initargs definition))) 379 (loop (when (null others) (return nil)) 380 (let ((initarg (pop others))) 381 (unless (eq initarg :direct-default-initargs) 382 (error "~@<The defclass option ~S is not supported by ~ 383 the bootstrap object system.~:@>" 384 initarg))) 385 (setq default-initargs 386 (nconc default-initargs (reverse (pop others))))))) 387 (reverse default-initargs))) 388 389(defun !bootstrap-slot-index (class-name slot-name) 390 (or (position slot-name (early-class-slots class-name)) 391 (error "~S not found" slot-name))) 392 393;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and 394;;; change the values of slots during bootstrapping. During 395;;; bootstrapping, there are only two kinds of objects whose slots we 396;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument 397;;; to these functions tells whether the object is a CLASS or a 398;;; SLOT-DEFINITION. 399;;; 400;;; Note that the way this works it stores the slot in the same place 401;;; in memory that the full object system will expect to find it 402;;; later. This is critical to the bootstrapping process, the whole 403;;; changeover to the full object system is predicated on this. 404;;; 405;;; One important point is that the layout of standard classes and 406;;; standard slots must be computed the same way in this file as it is 407;;; by the full object system later. 408(defmacro !bootstrap-get-slot (type object slot-name) 409 `(clos-slots-ref (get-slots ,object) 410 (!bootstrap-slot-index ,type ,slot-name))) 411(defun !bootstrap-set-slot (type object slot-name new-value) 412 (setf (!bootstrap-get-slot type object slot-name) new-value)) 413 414(defun early-class-name (class) 415 (!bootstrap-get-slot 'class class 'name)) 416 417(defun early-class-precedence-list (class) 418 (!bootstrap-get-slot 'pcl-class class '%class-precedence-list)) 419 420(defun early-class-name-of (instance) 421 (early-class-name (class-of instance))) 422 423(defun early-class-slotds (class) 424 (!bootstrap-get-slot 'slot-class class 'slots)) 425 426(defun early-slot-definition-name (slotd) 427 (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) 428 429(defun early-slot-definition-location (slotd) 430 (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) 431 432(defun early-slot-definition-info (slotd) 433 (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'info)) 434 435(defun early-accessor-method-slot-name (method) 436 (!bootstrap-get-slot 'standard-accessor-method method 'slot-name)) 437 438(unless (fboundp 'class-name-of) 439 (setf (symbol-function 'class-name-of) 440 (symbol-function 'early-class-name-of))) 441(unintern 'early-class-name-of) 442 443(defun early-class-direct-subclasses (class) 444 (!bootstrap-get-slot 'class class 'direct-subclasses)) 445 446(declaim (notinline load-defclass)) 447(defun load-defclass (name metaclass supers canonical-slots canonical-options 448 readers writers slot-names source-location &optional safe-p) 449 ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since 450 ;; during the bootstrap we won't have (SAFETY 3). 451 (declare (ignore safe-p)) 452 (sb-kernel::%%compiler-defclass name readers writers slot-names) 453 (let ((ecd (make-early-class-definition name 454 source-location 455 metaclass 456 (copy-tree supers) 457 (copy-tree canonical-slots) 458 (copy-tree canonical-options))) 459 (existing 460 (find name *early-class-definitions* :key #'ecd-class-name))) 461 (setq *early-class-definitions* 462 (cons ecd (remove existing *early-class-definitions*))) 463 ecd)) 464