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