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