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