src/pcl/structure-class.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 (defmethod initialize-internal-slot-functions :after
  27           ((slotd structure-effective-slot-definition))
  28   (let ((name (slot-definition-name slotd)))
  29     (initialize-internal-slot-reader-gfs name)
  30     (initialize-internal-slot-writer-gfs name)
  31     (initialize-internal-slot-boundp-gfs name)))
  32
  33 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
  34   :instance)
  35
  36 (defmethod class-prototype ((class structure-class))
  37   (with-slots (prototype) class
  38     (or prototype
  39         (setq prototype (make-class-prototype class)))))
  40
  41 (defmethod make-class-prototype ((class structure-class))
  42   (with-slots (wrapper defstruct-constructor) class
  43     (if defstruct-constructor
  44         (make-instance class)
  45       (let* ((proto (%allocate-instance--class *empty-vector*)))
  46          (shared-initialize proto t :check-initargs-legality-p nil)
  47          (setf (std-instance-wrapper proto) wrapper)
  48          proto))))
  49
  50 (defmethod make-direct-slotd ((class structure-class)
  51                               &rest initargs
  52                               &key
  53                               (name (error "Slot needs a name."))
  54                               (conc-name (class-defstruct-conc-name class))
  55                               (defstruct-accessor-symbol () acc-sym-p)
  56                               &allow-other-keys)
  57   (declare (ignore defstruct-accessor-symbol))
  58   (declare (type symbol name)
  59            (type simple-string conc-name))
  60   (let ((initargs (list* :class class :allow-other-keys T initargs)))
  61     (unless acc-sym-p
  62       (setf initargs
  63             (list* :defstruct-accessor-symbol
  64                    (intern (concatenate 'simple-string
  65                                         conc-name
  66                                         (symbol-name name))
  67                            (symbol-package (class-name class)))
  68                    initargs)))
  69     (apply #'make-instance
  70            (direct-slot-definition-class class initargs)
  71            initargs)))
  72
  73 (defun slot-definition-defstruct-slot-description (slot)
  74   (let ((type (slot-definition-type slot)))
  75     `(,(slot-definition-name slot) ,(slot-definition-initform slot)
  76       ,@(unless (eq type t) `(:type ,type)))))
  77
  78 (defmethod shared-initialize :after
  79       ((class structure-class)
  80        slot-names
  81        &key (direct-superclasses nil direct-superclasses-p)
  82             (direct-slots nil direct-slots-p)
  83             direct-default-initargs
  84             (predicate-name   nil predicate-name-p))
  85   (declare (ignore slot-names direct-default-initargs))
  86   (let* ((name (class-name class))
  87          (from-defclass-p (slot-value class 'from-defclass-p))
  88          (defstruct-form (defstruct-form name))
  89          (conc-name
  90            (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
  91                (slot-value class 'defstruct-conc-name)
  92                (format nil "~S structure class " name)))
  93          (defstruct-predicate
  94            (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
  95          (pred-name  ;; Predicate name for class
  96            (or (if predicate-name-p (car predicate-name))
  97                (if defstruct-form defstruct-predicate)
  98                (slot-value class 'predicate-name)
  99                (make-class-predicate-name name)))
 100          (constructor
 101            (or (if defstruct-form (defstruct-form-constructor defstruct-form))
 102                (slot-value class 'defstruct-constructor)
 103                (if from-defclass-p
 104                    (list (intern (format nil "~Aconstructor" conc-name)
 105                                  (symbol-package name))
 106                          ())))))
 107     (declare (type symbol       name defstruct-predicate pred-name)
 108              (type boolean       from-defclass-p)
 109              (type simple-string conc-name))
 110     (if direct-superclasses-p
 111         (setf (slot-value class 'direct-superclasses)
 112               (or direct-superclasses
 113                   (setq direct-superclasses
 114                         (if (eq name 'structure-object)
 115                             nil
 116                             (list *the-class-structure-object*)))))
 117         (setq direct-superclasses (slot-value class 'direct-superclasses)))
 118     (setq direct-slots
 119           (if direct-slots-p
 120               (setf (slot-value class 'direct-slots)
 121                     (mapcar #'(lambda (pl)
 122                                 (apply #'make-direct-slotd class
 123                                         :conc-name conc-name pl))
 124                             direct-slots))
 125               (slot-value class 'direct-slots)))
 126     (when from-defclass-p
 127       (do-defstruct-from-defclass
 128         class direct-superclasses
 129         direct-slots
 130         conc-name pred-name
 131         constructor))
 132     (compile-structure-class-internals
 133         class direct-slots conc-name pred-name constructor)
 134     (setf (slot-value class 'predicate-name) pred-name)
 135     (setf (slot-value class 'defstruct-conc-name) conc-name)
 136     (unless (extract-required-parameters (second constructor))
 137       (setf (slot-value class 'defstruct-constructor) (car constructor)))
 138     (when (and defstruct-predicate (not from-defclass-p))
 139       (fdefinition pred-name (symbol-function defstruct-predicate)))
 140     (unless (or from-defclass-p (slot-value class 'documentation))
 141       (setf (slot-value class 'documentation)
 142             (format nil "~S structure class made from Defstruct" name)))
 143     (setf (find-class name) class)
 144     (update-structure-class class direct-superclasses direct-slots)))
 145
 146 (defun update-structure-class (class direct-superclasses direct-slots)
 147   (add-direct-subclasses class direct-superclasses)
 148   (setf (slot-value class 'class-precedence-list)
 149         (compute-class-precedence-list class))
 150   (let* ((eslotds (compute-slots class))
 151          (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
 152     (setf (slot-value class 'slots) eslotds)
 153     (setf (slot-value class 'internal-slotds) internal-slotds)
 154     (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
 155   (unless (slot-value class 'wrapper)
 156     (setf (slot-value class 'finalized-p) T)
 157     (setf (slot-value class 'wrapper) (make-wrapper class)))
 158   (unless (slot-boundp class 'prototype)
 159     (setf (slot-value class 'prototype) nil))
 160   (setf (slot-value class 'default-initargs) nil)
 161   (add-slot-accessors class direct-slots))
 162
 163 (defmethod do-defstruct-from-defclass ((class structure-class)
 164                                        direct-superclasses direct-slots
 165                                        conc-name predicate constructor)
 166   (declare (type simple-string conc-name))
 167   (let* ((name (class-name class))
 168          (original-defstruct-form
 169           `(original-defstruct
 170               (,name
 171                  ,@(when direct-superclasses
 172                    `((:include ,(class-name (car direct-superclasses)))))
 173                  (:print-function print-std-instance)
 174                  (:predicate ,predicate)
 175                  (:conc-name ,(intern conc-name (symbol-package name)))
 176                  (:constructor ,@constructor))
 177             ,@(mapcar #'slot-definition-defstruct-slot-description
 178                       direct-slots))))
 179     (eval original-defstruct-form)
 180     (store-defstruct-form (cdr original-defstruct-form))))
 181
 182 (defmethod compile-structure-class-internals ((class structure-class)
 183                                               direct-slots conc-name
 184                                               predicate-name constructor)
 185   (declare (type simple-string conc-name))
 186   (let* ((name    (class-name class))
 187          (package (symbol-package name))
 188          (direct-slots-needing-internals
 189            (if (slot-value class 'from-defclass-p)
 190                direct-slots
 191                (remove-if #'slot-definition-internal-reader-function
 192                           direct-slots)))
 193          (reader-names
 194            (mapcar #'(lambda (slotd)
 195                        (intern (format nil "~A~A reader" conc-name
 196                                        (slot-definition-name slotd))
 197                                 package))
 198                    direct-slots-needing-internals))
 199          (writer-names
 200            (mapcar #'(lambda (slotd)
 201                        (intern (format nil "~A~A writer" conc-name
 202                                        (slot-definition-name slotd))
 203                                package))
 204                    direct-slots-needing-internals))
 205          (defstruct-accessor-names
 206            (mapcar #'slot-definition-defstruct-accessor-symbol
 207                    direct-slots-needing-internals))
 208          (readers-init
 209            (mapcar #'(lambda (defstruct-accessor reader-name)
 210                        `(progn
 211                           (force-compile ',defstruct-accessor)
 212                           (defun ,reader-name (obj)
 213                             (declare (type ,name obj) #.*optimize-speed*)
 214                             (,defstruct-accessor obj))
 215                           (force-compile ',reader-name)))
 216                    defstruct-accessor-names reader-names))
 217          (writers-init
 218            (mapcar #'(lambda (defstruct-accessor writer-name)
 219                        `(progn
 220                           (force-compile ',defstruct-accessor)
 221                           (defun ,writer-name (nv obj)
 222                             (declare (type ,name obj) #.*optimize-speed*)
 223                             (setf (,defstruct-accessor obj) nv))
 224                           (force-compile ',writer-name)))
 225                    defstruct-accessor-names writer-names))
 226          (defstruct-extras-form
 227            `(progn
 228               ,@(when (car constructor)
 229                   `((force-compile ',(car constructor))))
 230               ,@(when (fboundp predicate-name)
 231                   `((force-compile ',predicate-name)))
 232               ,@readers-init
 233               ,@writers-init)))
 234     (declare (type package package))
 235     (eval defstruct-extras-form)
 236     (mapc #'(lambda (dslotd reader-name writer-name)
 237               (setf (slot-value dslotd 'internal-reader-function)
 238                     (gdefinition reader-name))
 239               (setf (slot-value dslotd 'internal-writer-function)
 240                     (gdefinition writer-name)))
 241           direct-slots-needing-internals reader-names writer-names)))
 242
 243 (defmethod reinitialize-instance :after ((class structure-class)
 244                                          &rest initargs
 245                                          &key)
 246   (map-dependents class
 247                   #'(lambda (dependent)
 248                       (apply #'update-dependent class dependent initargs))))
 249
 250 (defmethod direct-slot-definition-class ((class structure-class) initargs)
 251   (declare (ignore initargs))
 252   (find-class 'structure-direct-slot-definition))
 253
 254 (defmethod effective-slot-definition-class ((class structure-class) initargs)
 255   (declare (ignore initargs))
 256   (find-class 'structure-effective-slot-definition))
 257
 258 (defmethod finalize-inheritance ((class structure-class))
 259   nil) ; always finalized
 260
 261 (defmethod compute-slots ((class structure-class))
 262   (mapcan #'(lambda (superclass)
 263               (mapcar #'(lambda (dslotd)
 264                           (compute-effective-slot-definition
 265                              class (slot-definition-name dslotd) (list dslotd)))
 266                       (class-direct-slots superclass)))
 267           (reverse (slot-value class 'class-precedence-list))))
 268
 269 (defmethod compute-slots :around ((class structure-class))
 270   (let ((eslotds (call-next-method)))
 271     (mapc #'initialize-internal-slot-functions eslotds)
 272     eslotds))
 273
 274 (defmethod compute-effective-slot-definition ((class structure-class)
 275                                               name dslotds)
 276   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
 277          (class (effective-slot-definition-class class initargs))
 278          (slot-definition (apply #'make-instance class initargs))
 279          (internal-slotd
 280            (make-internal-slotd
 281              :name name
 282              :slot-definition slot-definition
 283              :initargs  (slot-definition-initargs     slot-definition)
 284              :initfunction    (slot-definition-initfunction slot-definition))))
 285     (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
 286     slot-definition))
 287
 288 (defmethod compute-effective-slot-definition-initargs :around
 289     ((class structure-class) direct-slotds)
 290   (let ((slotd (car direct-slotds)))
 291     (list* :defstruct-accessor-symbol
 292            (slot-definition-defstruct-accessor-symbol slotd)
 293            :internal-reader-function
 294            (slot-definition-internal-reader-function slotd)
 295            :internal-writer-function
 296            (slot-definition-internal-writer-function slotd)
 297            (call-next-method))))
 298
 299 (defmethod make-optimized-reader-method-function ((class structure-class)
 300                                                   generic-function
 301                                                   reader-method-prototype
 302                                                   slot-name)
 303   (declare (ignore generic-function reader-method-prototype))
 304   (make-structure-instance-reader-method-function slot-name))
 305
 306 (defmethod make-optimized-writer-method-function ((class structure-class)
 307                                                   generic-function
 308                                                   writer-method-prototype
 309                                                   slot-name)
 310   (declare (ignore generic-function writer-method-prototype))
 311   (make-structure-instance-writer-method-function slot-name))
 312
 313 (defmethod make-optimized-boundp-method-function ((class structure-class)
 314                                                   generic-function
 315                                                   boundp-method-prototype
 316                                                   slot-name)
 317   (declare (ignore generic-function boundp-method-prototype))
 318   (make-structure-instance-boundp-method-function slot-name))
 319
 320 (defun make-structure-instance-reader-method-function (slot-name)
 321   (declare #.*optimize-speed*)
 322   #'(lambda (instance)
 323       (structure-instance-slot-value instance slot-name)))
 324
 325 (defun make-structure-instance-writer-method-function (slot-name)
 326   (declare #.*optimize-speed*)
 327   #'(lambda (nv instance)
 328       (setf (structure-instance-slot-value instance slot-name) nv)))
 329
 330 (defun make-structure-instance-boundp-method-function (slot-name)
 331   (declare #.*optimize-speed*)
 332   #'(lambda (instance)
 333       (structure-instance-slot-boundp instance slot-name)))
 334
 335 (defmethod wrapper-fetcher ((class structure-class))
 336   'wrapper-for-structure)
 337
 338 (defmethod slots-fetcher ((class structure-class))
 339   nil)