src/pcl/defclass.lisp

   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 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 ;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
  30 ;;;
  31 ;;; The original motiviation for this function was to deal with the bug in
  32 ;;; the Genera compiler that prevents lambda expressions in top-level forms
  33 ;;; other than DEFUN from being compiled.
  34 ;;;
  35 ;;; Now this function is used to grab other functionality as well. This
  36 ;;; includes:
  37 ;;;   - Preventing the grouping of top-level forms. For example, a
  38 ;;;     DEFCLASS followed by a DEFMETHOD may not want to be grouped
  39 ;;;     into the same top-level form.
  40 ;;;   - Telling the programming environment what the pretty version
  41 ;;;     of the name of this form is. This is used by WARN.
  42 ;;;
  43 ;;; FIXME: It's not clear that this adds value any more. Couldn't
  44 ;;; we just use EVAL-WHEN?
  45 (defun make-top-level-form (name times form)
  46   (flet ((definition-name ()
  47            (if (and (listp name)
  48                     (memq (car name)
  49                           '(defmethod defclass class
  50                             method method-combination)))
  51                (format nil "~A~{ ~S~}"
  52                        (capitalize-words (car name) ()) (cdr name))
  53                (format nil "~S" name))))
  54     ;; FIXME: It appears that we're just consing up a string and then
  55     ;; throwing it away?!
  56     (definition-name)
  57     (if (or (member 'compile times)
  58             (member ':compile-toplevel times))
  59         `(eval-when ,times ,form)
  60         form)))
  61
  62 (defun make-progn (&rest forms)
  63   (let ((progn-form nil))
  64     (labels ((collect-forms (forms)
  65                (unless (null forms)
  66                  (collect-forms (cdr forms))
  67                  (if (and (listp (car forms))
  68                           (eq (caar forms) 'progn))
  69                      (collect-forms (cdar forms))
  70                      (push (car forms) progn-form)))))
  71       (collect-forms forms)
  72       (cons 'progn progn-form))))
  73 \f
  74 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
  75 ;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta-
  76 ;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
  77 ;;; collects all class definitions up, when the metabraid is initialized it
  78 ;;; is done from those class definitions.
  79 ;;;
  80 ;;; After the metabraid has been setup, and the protocol for defining classes
  81 ;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
  82 ;;; file defclass.lisp
  83 (defmacro defclass (name direct-superclasses direct-slots &rest options)
  84   (declare (indentation 2 4 3 1))
  85   (expand-defclass name direct-superclasses direct-slots options))
  86
  87 (defun expand-defclass (name supers slots options)
  88   (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
  89   (setq supers  (copy-tree supers)
  90         slots   (copy-tree slots)
  91         options (copy-tree options))
  92   (let ((metaclass 'standard-class))
  93     (dolist (option options)
  94       (if (not (listp option))
  95           (error "~S is not a legal defclass option." option)
  96           (when (eq (car option) ':metaclass)
  97             (unless (legal-class-name-p (cadr option))
  98               (error "The value of the :metaclass option (~S) is not a~%~
  99                       legal class name."
 100                      (cadr option)))
 101             (setq metaclass
 102                   (case (cadr option)
 103                     (cl:standard-class 'standard-class)
 104                     (cl:structure-class 'structure-class)
 105                     (t (cadr option))))
 106             (setf options (remove option options))
 107             (return t))))
 108
 109     (let ((*initfunctions* ())
 110           (*accessors* ())              ;Truly a crock, but we got
 111           (*readers* ())                ;to have it to live nicely.
 112           (*writers* ()))
 113       (declare (special *initfunctions* *accessors* *readers* *writers*))
 114       (let ((canonical-slots
 115               (mapcar #'(lambda (spec)
 116                           (canonicalize-slot-specification name spec))
 117                       slots))
 118             (other-initargs
 119               (mapcar #'(lambda (option)
 120                           (canonicalize-defclass-option name option))
 121                       options))
 122             (defstruct-p (and (eq *boot-state* 'complete)
 123                               (let ((mclass (find-class metaclass nil)))
 124                                 (and mclass
 125                                      (*subtypep mclass
 126                                                 *the-class-structure-class*))))))
 127         (do-standard-defsetfs-for-defclass *accessors*)
 128         (let ((defclass-form
 129                  (make-top-level-form `(defclass ,name)
 130                    (if defstruct-p '(:load-toplevel :execute) *defclass-times*)
 131                    `(progn
 132                       ,@(mapcar #'(lambda (x)
 133                                     `(declaim (ftype (function (t) t) ,x)))
 134                                 *readers*)
 135                       ,@(mapcar #'(lambda (x)
 136                                     #-setf (when (consp x)
 137                                              (setq x (get-setf-function-name (cadr x))))
 138                                     `(declaim (ftype (function (t t) t) ,x)))
 139                                 *writers*)
 140                       (let ,(mapcar #'cdr *initfunctions*)
 141                         (load-defclass ',name
 142                                        ',metaclass
 143                                        ',supers
 144                                        (list ,@canonical-slots)
 145                                        (list ,@(apply #'append
 146                                                       (when defstruct-p
 147                                                         '(:from-defclass-p t))
 148                                                       other-initargs))
 149                                        ',*accessors*))))))
 150           (if defstruct-p
 151               (progn
 152                 (eval defclass-form) ; define the class now, so that
 153                 `(progn       ; the defstruct can be compiled.
 154                    ,(class-defstruct-form (find-class name))
 155                    ,defclass-form))
 156               (progn
 157                 (when (and (eq *boot-state* 'complete)
 158                            (not (member 'compile *defclass-times*)))
 159                   (inform-type-system-about-std-class name))
 160                 defclass-form)))))))
 161
 162 (defun make-initfunction (initform)
 163   (declare (special *initfunctions*))
 164   (cond ((or (eq initform 't)
 165              (equal initform ''t))
 166          '(function true))
 167         ((or (eq initform 'nil)
 168              (equal initform ''nil))
 169          '(function false))
 170         ((or (eql initform '0)
 171              (equal initform ''0))
 172          '(function zero))
 173         (t
 174          (let ((entry (assoc initform *initfunctions* :test #'equal)))
 175            (unless entry
 176              (setq entry (list initform
 177                                (gensym)
 178                                `(function (lambda () ,initform))))
 179              (push entry *initfunctions*))
 180            (cadr entry)))))
 181
 182 (defun canonicalize-slot-specification (class-name spec)
 183   (declare (special *accessors* *readers* *writers*))
 184   (cond ((and (symbolp spec)
 185               (not (keywordp spec))
 186               (not (memq spec '(t nil))))
 187          `'(:name ,spec))
 188         ((not (consp spec))
 189          (error "~S is not a legal slot specification." spec))
 190         ((null (cdr spec))
 191          `'(:name ,(car spec)))
 192         ((null (cddr spec))
 193          (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
 194                  Convert it to ~S"
 195                 class-name spec (list (car spec) :initform (cadr spec))))
 196         (t
 197          (let* ((name (pop spec))
 198                 (readers ())
 199                 (writers ())
 200                 (initargs ())
 201                 (unsupplied (list nil))
 202                 (initform (getf spec :initform unsupplied)))
 203            (doplist (key val) spec
 204              (case key
 205                (:accessor (push val *accessors*)
 206                           (push val readers)
 207                           (push `(setf ,val) writers))
 208                (:reader   (push val readers))
 209                (:writer   (push val writers))
 210                (:initarg  (push val initargs))))
 211            (loop (unless (remf spec :accessor) (return)))
 212            (loop (unless (remf spec :reader)   (return)))
 213            (loop (unless (remf spec :writer)   (return)))
 214            (loop (unless (remf spec :initarg)  (return)))
 215            (setq *writers* (append writers *writers*))
 216            (setq *readers* (append readers *readers*))
 217            (setq spec `(:name     ',name
 218                         :readers  ',readers
 219                         :writers  ',writers
 220                         :initargs ',initargs
 221                         ',spec))
 222            (if (eq initform unsupplied)
 223                `(list* ,@spec)
 224                `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
 225
 226 (defun canonicalize-defclass-option (class-name option)
 227   (declare (ignore class-name))
 228   (case (car option)
 229     (:default-initargs
 230       (let ((canonical ()))
 231         (let (key val (tail (cdr option)))
 232           (loop (when (null tail) (return nil))
 233                 (setq key (pop tail)
 234                       val (pop tail))
 235                 (push ``(,',key ,,(make-initfunction val) ,',val) canonical))
 236           `(':direct-default-initargs (list ,@(nreverse canonical))))))
 237     (:documentation
 238       `(',(car option) ',(cadr option)))
 239     (otherwise
 240      `(',(car option) ',(cdr option)))))
 241 \f
 242 ;;; This is the early definition of load-defclass. It just collects up
 243 ;;; all the class definitions in a list. Later, in the file
 244 ;;; braid1.lisp, these are actually defined.
 245
 246 ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
 247 (defparameter *early-class-definitions* ())
 248
 249 (defun early-class-definition (class-name)
 250   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
 251       (error "~S is not a class in *early-class-definitions*." class-name)))
 252
 253 (defun make-early-class-definition
 254        (name source metaclass
 255         superclass-names canonical-slots other-initargs)
 256   (list 'early-class-definition
 257         name source metaclass
 258         superclass-names canonical-slots other-initargs))
 259
 260 (defun ecd-class-name        (ecd) (nth 1 ecd))
 261 (defun ecd-source            (ecd) (nth 2 ecd))
 262 (defun ecd-metaclass         (ecd) (nth 3 ecd))
 263 (defun ecd-superclass-names  (ecd) (nth 4 ecd))
 264 (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
 265 (defun ecd-other-initargs    (ecd) (nth 6 ecd))
 266
 267 (defvar *early-class-slots* nil)
 268
 269 (defun canonical-slot-name (canonical-slot)
 270   (getf canonical-slot :name))
 271
 272 (defun early-class-slots (class-name)
 273   (cdr (or (assoc class-name *early-class-slots*)
 274            (let ((a (cons class-name
 275                           (mapcar #'canonical-slot-name
 276                                   (early-collect-inheritance class-name)))))
 277              (push a *early-class-slots*)
 278              a))))
 279
 280 (defun early-class-size (class-name)
 281   (length (early-class-slots class-name)))
 282
 283 (defun early-collect-inheritance (class-name)
 284   ;;(declare (values slots cpl default-initargs direct-subclasses))
 285   (let ((cpl (early-collect-cpl class-name)))
 286     (values (early-collect-slots cpl)
 287             cpl
 288             (early-collect-default-initargs cpl)
 289             (gathering1 (collecting)
 290               (dolist (definition *early-class-definitions*)
 291                 (when (memq class-name (ecd-superclass-names definition))
 292                   (gather1 (ecd-class-name definition))))))))
 293
 294 (defun early-collect-slots (cpl)
 295   (let* ((definitions (mapcar #'early-class-definition cpl))
 296          (super-slots (mapcar #'ecd-canonical-slots definitions))
 297          (slots (apply #'append (reverse super-slots))))
 298     (dolist (s1 slots)
 299       (let ((name1 (canonical-slot-name s1)))
 300         (dolist (s2 (cdr (memq s1 slots)))
 301           (when (eq name1 (canonical-slot-name s2))
 302             (error "More than one early class defines a slot with the~%~
 303                     name ~S. This can't work because the bootstrap~%~
 304                     object system doesn't know how to compute effective~%~
 305                     slots."
 306                    name1)))))
 307     slots))
 308
 309 (defun early-collect-cpl (class-name)
 310   (labels ((walk (c)
 311              (let* ((definition (early-class-definition c))
 312                     (supers (ecd-superclass-names definition)))
 313                (cons c
 314                      (apply #'append (mapcar #'early-collect-cpl supers))))))
 315     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
 316
 317 (defun early-collect-default-initargs (cpl)
 318   (let ((default-initargs ()))
 319     (dolist (class-name cpl)
 320       (let* ((definition (early-class-definition class-name))
 321              (others (ecd-other-initargs definition)))
 322         (loop (when (null others) (return nil))
 323               (let ((initarg (pop others)))
 324                 (unless (eq initarg :direct-default-initargs)
 325                  (error "The defclass option ~S is not supported by the bootstrap~%~
 326                         object system."
 327                         initarg)))
 328               (setq default-initargs
 329                     (nconc default-initargs (reverse (pop others)))))))
 330     (reverse default-initargs)))
 331
 332 (defun bootstrap-slot-index (class-name slot-name)
 333   (or (position slot-name (early-class-slots class-name))
 334       (error "~S not found" slot-name)))
 335
 336 ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the
 337 ;;; values of slots during bootstrapping. During bootstrapping, there are only
 338 ;;; two kinds of objects whose slots we need to access, CLASSes and
 339 ;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the
 340 ;;; object is a CLASS or a SLOT-DEFINITION.
 341 ;;;
 342 ;;; Note that the way this works it stores the slot in the same place in
 343 ;;; memory that the full object system will expect to find it later. This
 344 ;;; is critical to the bootstrapping process, the whole changeover to the
 345 ;;; full object system is predicated on this.
 346 ;;;
 347 ;;; One important point is that the layout of standard classes and standard
 348 ;;; slots must be computed the same way in this file as it is by the full
 349 ;;; object system later.
 350 (defmacro bootstrap-get-slot (type object slot-name)
 351   `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
 352 (defun bootstrap-set-slot (type object slot-name new-value)
 353   (setf (bootstrap-get-slot type object slot-name) new-value))
 354
 355 (defun early-class-name (class)
 356   (bootstrap-get-slot 'class class 'name))
 357
 358 (defun early-class-precedence-list (class)
 359   (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
 360
 361 (defun early-class-name-of (instance)
 362   (early-class-name (class-of instance)))
 363
 364 (defun early-class-slotds (class)
 365   (bootstrap-get-slot 'slot-class class 'slots))
 366
 367 (defun early-slot-definition-name (slotd)
 368   (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
 369
 370 (defun early-slot-definition-location (slotd)
 371   (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
 372
 373 (defun early-accessor-method-slot-name (method)
 374   (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
 375
 376 (unless (fboundp 'class-name-of)
 377   (setf (symbol-function 'class-name-of)
 378         (symbol-function 'early-class-name-of)))
 379 ;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF?
 380
 381 (defun early-class-direct-subclasses (class)
 382   (bootstrap-get-slot 'class class 'direct-subclasses))
 383
 384 (declaim (notinline load-defclass))
 385 (defun load-defclass
 386        (name metaclass supers canonical-slots canonical-options accessor-names)
 387   (setq supers  (copy-tree supers)
 388         canonical-slots   (copy-tree canonical-slots)
 389         canonical-options (copy-tree canonical-options))
 390   (do-standard-defsetfs-for-defclass accessor-names)
 391   (when (eq metaclass 'standard-class)
 392     (inform-type-system-about-std-class name))
 393   (let ((ecd
 394           (make-early-class-definition name
 395                                        *load-truename*
 396                                        metaclass
 397                                        supers
 398                                        canonical-slots
 399                                        canonical-options))
 400         (existing
 401           (find name *early-class-definitions* :key #'ecd-class-name)))
 402     (setq *early-class-definitions*
 403           (cons ecd (remove existing *early-class-definitions*)))
 404     ecd))
 405