src/pcl/slots-boot.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 (defun ensure-accessor (type fun-name slot-name)
  27   (labels ((slot-missing-fun (slot-name type)
  28              (let* ((method-type (ecase type
  29                                    (slot-value 'reader-method)
  30                                    (setf 'writer-method)
  31                                    (slot-boundp 'boundp-method)))
  32                     (initargs
  33                      (copy-tree
  34                       (ecase type
  35                         (slot-value
  36                          (make-method-function
  37                           (lambda (obj)
  38                             (values
  39                              (slot-missing (class-of obj) obj slot-name
  40                                            'slot-value)))))
  41                         (slot-boundp
  42                          (make-method-function
  43                           (lambda (obj)
  44                             (not (not
  45                                   (slot-missing (class-of obj) obj slot-name
  46                                                 'slot-boundp))))))
  47                         (setf
  48                          (make-method-function
  49                           (lambda (val obj)
  50                             (slot-missing (class-of obj) obj slot-name
  51                                           'setf val)
  52                             val)))))))
  53                (setf (getf (getf initargs :plist) :slot-name-lists)
  54                      (list (list nil slot-name)))
  55                (setf (getf (getf initargs :plist) :pv-table-symbol)
  56                      (gensym))
  57                (list* :method-spec (list method-type 'slot-object slot-name)
  58                       initargs)))
  59            (add-slot-missing-method (gf slot-name type)
  60              (multiple-value-bind (class lambda-list specializers)
  61                  (ecase type
  62                    (slot-value
  63                     (values 'standard-reader-method
  64                             '(object)
  65                             (list *the-class-slot-object*)))
  66                    (slot-boundp
  67                     (values 'standard-boundp-method
  68                             '(object)
  69                             (list *the-class-slot-object*)))
  70                    (setf
  71                     (values 'standard-writer-method
  72                             '(new-value object)
  73                             (list *the-class-t* *the-class-slot-object*))))
  74                (add-method gf (make-a-method class
  75                                              ()
  76                                              lambda-list
  77                                              specializers
  78                                              (slot-missing-fun slot-name type)
  79                                              "generated slot-missing method"
  80                                              slot-name)))))
  81     (unless (fboundp fun-name)
  82       (let ((gf (ensure-generic-function
  83                  fun-name
  84                  :lambda-list (ecase type
  85                                 ((reader boundp) '(object))
  86                                 (writer '(new-value object))))))
  87         (ecase type
  88           (reader (add-slot-missing-method gf slot-name 'slot-value))
  89           (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
  90           (writer (add-slot-missing-method gf slot-name 'setf)))
  91         (setf (plist-value gf 'slot-missing-method) t))
  92       t)))
  93
  94 (defmacro accessor-slot-value (object slot-name)
  95   (aver (constantp slot-name))
  96   (let* ((slot-name (eval slot-name))
  97          (reader-name (slot-reader-name slot-name)))
  98     `(let ((.ignore. (load-time-value
  99                       (ensure-accessor 'reader ',reader-name ',slot-name))))
 100       (declare (ignore .ignore.))
 101       (truly-the (values t &optional)
 102                  (funcall #',reader-name ,object)))))
 103
 104 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
 105   (aver (constantp slot-name))
 106   (setq object (macroexpand object env))
 107   (setq slot-name (macroexpand slot-name env))
 108   (let* ((slot-name (eval slot-name))
 109          (bindings (unless (or (constantp new-value) (atom new-value))
 110                      (let ((object-var (gensym)))
 111                        (prog1 `((,object-var ,object))
 112                          (setq object object-var)))))
 113          (writer-name (slot-writer-name slot-name))
 114          (form
 115           `(let ((.ignore.
 116                   (load-time-value
 117                    (ensure-accessor 'writer ',writer-name ',slot-name)))
 118                  (.new-value. ,new-value))
 119             (declare (ignore .ignore.))
 120             (funcall #',writer-name .new-value. ,object)
 121             .new-value.)))
 122     (if bindings
 123         `(let ,bindings ,form)
 124         form)))
 125
 126 (defmacro accessor-slot-boundp (object slot-name)
 127   (aver (constantp slot-name))
 128   (let* ((slot-name (eval slot-name))
 129          (boundp-name (slot-boundp-name slot-name)))
 130     `(let ((.ignore. (load-time-value
 131                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
 132       (declare (ignore .ignore.))
 133       (funcall #',boundp-name ,object))))
 134
 135 (defun make-structure-slot-boundp-function (slotd)
 136   (declare (ignore slotd))
 137   (lambda (object)
 138     (declare (ignore object))
 139     t))
 140
 141 (define-condition instance-structure-protocol-error
 142     (reference-condition error)
 143   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
 144    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
 145   (:report
 146    (lambda (c s)
 147      (format s "~@<The slot ~S has neither ~S nor ~S ~
 148                 allocation, so it can't be ~A by the default ~
 149                 ~S method.~@:>"
 150              (instance-structure-protocol-error-slotd c)
 151              :instance :class
 152              (cond
 153                ((member (instance-structure-protocol-error-fun c)
 154                         '(slot-value-using-class slot-boundp-using-class))
 155                 "read")
 156                (t "written"))
 157              (instance-structure-protocol-error-fun c)))))
 158
 159 (defun instance-structure-protocol-error (slotd fun)
 160   (error 'instance-structure-protocol-error
 161          :slotd slotd :fun fun
 162          :references (list `(:amop :generic-function ,fun)
 163                            '(:amop :section (5 5 3)))))
 164
 165 (defun get-optimized-std-accessor-method-function (class slotd name)
 166   (cond
 167     ((structure-class-p class)
 168      (ecase name
 169        (reader (slot-definition-internal-reader-function slotd))
 170        (writer (slot-definition-internal-writer-function slotd))
 171        (boundp (make-structure-slot-boundp-function slotd))))
 172     ((condition-class-p class)
 173      (ecase name
 174        (reader (slot-definition-reader-function slotd))
 175        (writer (slot-definition-writer-function slotd))
 176        (boundp (slot-definition-boundp-function slotd))))
 177     (t
 178      (let* ((fsc-p (cond ((standard-class-p class) nil)
 179                          ((funcallable-standard-class-p class) t)
 180                          ((std-class-p class)
 181                           ;; Shouldn't be using the optimized-std-accessors
 182                           ;; in this case.
 183                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 184                                         name slotd class)
 185                           nil)
 186                          (t (error "~S is not a STANDARD-CLASS." class))))
 187             (slot-name (slot-definition-name slotd))
 188             (location (slot-definition-location slotd))
 189             (function (ecase name
 190                         (reader #'make-optimized-std-reader-method-function)
 191                         (writer #'make-optimized-std-writer-method-function)
 192                         (boundp #'make-optimized-std-boundp-method-function)))
 193             ;; KLUDGE: we need this slightly hacky calling convention
 194             ;; for these functions for bootstrapping reasons: see
 195             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 196             ;; 2004-07-12
 197             (value (funcall function fsc-p slotd slot-name location)))
 198        (declare (type function function))
 199        (values value (slot-definition-location slotd))))))
 200
 201 (defun make-optimized-std-reader-method-function
 202     (fsc-p slotd slot-name location)
 203   (declare #.*optimize-speed*)
 204   (set-fun-name
 205    (etypecase location
 206      (fixnum
 207       (if fsc-p
 208           (lambda (instance)
 209             (check-obsolete-instance instance)
 210             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 211                                          location)))
 212               (if (eq value +slot-unbound+)
 213                   (values
 214                    (slot-unbound (class-of instance) instance slot-name))
 215                   value)))
 216           (lambda (instance)
 217             (check-obsolete-instance instance)
 218             (let ((value (clos-slots-ref (std-instance-slots instance)
 219                                          location)))
 220               (if (eq value +slot-unbound+)
 221                   (values
 222                    (slot-unbound (class-of instance) instance slot-name))
 223                   value)))))
 224      (cons
 225       (lambda (instance)
 226         (check-obsolete-instance instance)
 227         (let ((value (cdr location)))
 228           (if (eq value +slot-unbound+)
 229               (values (slot-unbound (class-of instance) instance slot-name))
 230               value))))
 231      (null
 232       (lambda (instance)
 233         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 234    `(reader ,slot-name)))
 235
 236 (defun make-optimized-std-writer-method-function
 237     (fsc-p slotd slot-name location)
 238   (declare #.*optimize-speed*)
 239   (set-fun-name
 240    (etypecase location
 241      (fixnum (if fsc-p
 242                  (lambda (nv instance)
 243                    (check-obsolete-instance instance)
 244                    (setf (clos-slots-ref (fsc-instance-slots instance)
 245                                          location)
 246                          nv))
 247                  (lambda (nv instance)
 248                    (check-obsolete-instance instance)
 249                    (setf (clos-slots-ref (std-instance-slots instance)
 250                                          location)
 251                          nv))))
 252      (cons (lambda (nv instance)
 253              (check-obsolete-instance instance)
 254              (setf (cdr location) nv)))
 255      (null
 256       (lambda (nv instance)
 257         (declare (ignore nv))
 258         (instance-structure-protocol-error slotd
 259                                            '(setf slot-value-using-class)))))
 260    `(writer ,slot-name)))
 261
 262 (defun make-optimized-std-boundp-method-function
 263     (fsc-p slotd slot-name location)
 264   (declare #.*optimize-speed*)
 265   (set-fun-name
 266    (etypecase location
 267      (fixnum (if fsc-p
 268                  (lambda (instance)
 269                    (check-obsolete-instance instance)
 270                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 271                                             location)
 272                             +slot-unbound+)))
 273                  (lambda (instance)
 274                    (check-obsolete-instance instance)
 275                    (not (eq (clos-slots-ref (std-instance-slots instance)
 276                                             location)
 277                             +slot-unbound+)))))
 278      (cons (lambda (instance)
 279              (check-obsolete-instance instance)
 280              (not (eq (cdr location) +slot-unbound+))))
 281      (null
 282       (lambda (instance)
 283         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 284    `(boundp ,slot-name)))
 285
 286 (defun make-optimized-structure-slot-value-using-class-method-function
 287     (function)
 288   (declare (type function function))
 289   (lambda (class object slotd)
 290     (declare (ignore class slotd))
 291     (funcall function object)))
 292
 293 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 294     (function)
 295   (declare (type function function))
 296   (lambda (nv class object slotd)
 297     (declare (ignore class slotd))
 298     (funcall function nv object)))
 299
 300 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 301   (lambda (class object slotd)
 302     (declare (ignore class object slotd))
 303     t))
 304
 305 (defun get-optimized-std-slot-value-using-class-method-function
 306     (class slotd name)
 307   (cond
 308     ((structure-class-p class)
 309      (ecase name
 310        (reader (make-optimized-structure-slot-value-using-class-method-function
 311                 (slot-definition-internal-reader-function slotd)))
 312        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 313                 (slot-definition-internal-writer-function slotd)))
 314        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
 315     ((condition-class-p class)
 316      (ecase name
 317        (reader
 318         (let ((fun (slot-definition-reader-function slotd)))
 319           (declare (type function fun))
 320           (lambda (class object slotd)
 321             (declare (ignore class slotd))
 322             (funcall fun object))))
 323        (writer
 324         (let ((fun (slot-definition-writer-function slotd)))
 325           (declare (type function fun))
 326           (lambda (new-value class object slotd)
 327             (declare (ignore class slotd))
 328             (funcall fun new-value object))))
 329        (boundp
 330         (let ((fun (slot-definition-boundp-function slotd)))
 331           (declare (type function fun))
 332           (lambda (class object slotd)
 333             (declare (ignore class slotd))
 334             (funcall fun object))))))
 335     (t
 336      (let* ((fsc-p (cond ((standard-class-p class) nil)
 337                          ((funcallable-standard-class-p class) t)
 338                          (t (error "~S is not a standard-class" class))))
 339             (function
 340              (ecase name
 341                (reader
 342                 #'make-optimized-std-slot-value-using-class-method-function)
 343                (writer
 344                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 345                (boundp
 346                 #'make-optimized-std-slot-boundp-using-class-method-function))))
 347        (declare (type function function))
 348        (values (funcall function fsc-p slotd)
 349                (slot-definition-location slotd))))))
 350
 351 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 352   (declare #.*optimize-speed*)
 353   (let ((location (slot-definition-location slotd))
 354         (slot-name (slot-definition-name slotd)))
 355     (etypecase location
 356       (fixnum (if fsc-p
 357                   (lambda (class instance slotd)
 358                     (declare (ignore slotd))
 359                     (check-obsolete-instance instance)
 360                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 361                                                  location)))
 362                       (if (eq value +slot-unbound+)
 363                           (values (slot-unbound class instance slot-name))
 364                           value)))
 365                   (lambda (class instance slotd)
 366                     (declare (ignore slotd))
 367                     (check-obsolete-instance instance)
 368                     (let ((value (clos-slots-ref (std-instance-slots instance)
 369                                                  location)))
 370                       (if (eq value +slot-unbound+)
 371                           (values (slot-unbound class instance slot-name))
 372                           value)))))
 373       (cons (lambda (class instance slotd)
 374               (declare (ignore slotd))
 375               (check-obsolete-instance instance)
 376               (let ((value (cdr location)))
 377                 (if (eq value +slot-unbound+)
 378                     (values (slot-unbound class instance slot-name))
 379                     value))))
 380       (null
 381        (lambda (class instance slotd)
 382          (declare (ignore class instance))
 383          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 384
 385 (defun make-optimized-std-setf-slot-value-using-class-method-function
 386     (fsc-p slotd)
 387   (declare #.*optimize-speed*)
 388   (let ((location (slot-definition-location slotd)))
 389     (etypecase location
 390       (fixnum
 391        (if fsc-p
 392            (lambda (nv class instance slotd)
 393              (declare (ignore class slotd))
 394              (check-obsolete-instance instance)
 395              (setf (clos-slots-ref (fsc-instance-slots instance) location)
 396                    nv))
 397            (lambda (nv class instance slotd)
 398              (declare (ignore class slotd))
 399              (check-obsolete-instance instance)
 400              (setf (clos-slots-ref (std-instance-slots instance) location)
 401                    nv))))
 402       (cons (lambda (nv class instance slotd)
 403               (declare (ignore class slotd))
 404               (check-obsolete-instance instance)
 405               (setf (cdr location) nv)))
 406       (null (lambda (nv class instance slotd)
 407               (declare (ignore nv class instance))
 408               (instance-structure-protocol-error
 409                slotd '(setf slot-value-using-class)))))))
 410
 411 (defun make-optimized-std-slot-boundp-using-class-method-function
 412     (fsc-p slotd)
 413   (declare #.*optimize-speed*)
 414   (let ((location (slot-definition-location slotd)))
 415     (etypecase location
 416       (fixnum
 417        (if fsc-p
 418            (lambda (class instance slotd)
 419              (declare (ignore class slotd))
 420              (check-obsolete-instance instance)
 421              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
 422                       +slot-unbound+)))
 423            (lambda (class instance slotd)
 424              (declare (ignore class slotd))
 425              (check-obsolete-instance instance)
 426              (not (eq (clos-slots-ref (std-instance-slots instance) location)
 427                       +slot-unbound+)))))
 428       (cons (lambda (class instance slotd)
 429               (declare (ignore class slotd))
 430               (check-obsolete-instance instance)
 431               (not (eq (cdr location) +slot-unbound+))))
 432       (null
 433        (lambda (class instance slotd)
 434          (declare (ignore class instance))
 435          (instance-structure-protocol-error slotd
 436                                             'slot-boundp-using-class))))))
 437
 438 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 439   (macrolet ((emf-funcall (emf &rest args)
 440                `(invoke-effective-method-function ,emf nil ,@args)))
 441     (set-fun-name
 442      (case name
 443        (reader (lambda (instance)
 444                  (emf-funcall sdfun class instance slotd)))
 445        (writer (lambda (nv instance)
 446                  (emf-funcall sdfun nv class instance slotd)))
 447        (boundp (lambda (instance)
 448                  (emf-funcall sdfun class instance slotd))))
 449      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 450
 451 (defun make-internal-reader-method-function (class-name slot-name)
 452   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
 453          (make-method-function
 454           (lambda (instance)
 455             (let ((wrapper (get-instance-wrapper-or-nil instance)))
 456               (if wrapper
 457                   (let* ((class (wrapper-class* wrapper))
 458                          (index (or (instance-slot-index wrapper slot-name)
 459                                     (assq slot-name
 460                                           (wrapper-class-slots wrapper)))))
 461                     (typecase index
 462                       (fixnum
 463                        (let ((value (clos-slots-ref (get-slots instance)
 464                                                     index)))
 465                          (if (eq value +slot-unbound+)
 466                              (values (slot-unbound (class-of instance)
 467                                                    instance
 468                                                    slot-name))
 469                              value)))
 470                       (cons
 471                        (let ((value (cdr index)))
 472                          (if (eq value +slot-unbound+)
 473                              (values (slot-unbound (class-of instance)
 474                                                    instance
 475                                                    slot-name))
 476                              value)))
 477                       (t
 478                        (error "~@<The wrapper for class ~S does not have ~
 479                                the slot ~S~@:>"
 480                               class slot-name))))
 481                   (slot-value instance slot-name)))))))
 482 \f
 483 (defun make-std-reader-method-function (class-name slot-name)
 484   (let* ((pv-table-symbol (gensym))
 485          (initargs (copy-tree
 486                     (make-method-function
 487                      (lambda (instance)
 488                        (pv-binding1 (.pv. .calls.
 489                                           (symbol-value pv-table-symbol)
 490                                           (instance) (instance-slots))
 491                          (instance-read-internal
 492                           .pv. instance-slots 1
 493                           (slot-value instance slot-name))))))))
 494     (setf (getf (getf initargs :plist) :slot-name-lists)
 495           (list (list nil slot-name)))
 496     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 497     (list* :method-spec `(reader-method ,class-name ,slot-name)
 498            initargs)))
 499
 500 (defun make-std-writer-method-function (class-name slot-name)
 501   (let* ((pv-table-symbol (gensym))
 502          (initargs (copy-tree
 503                     (make-method-function
 504                      (lambda (nv instance)
 505                        (pv-binding1 (.pv. .calls.
 506                                           (symbol-value pv-table-symbol)
 507                                           (instance) (instance-slots))
 508                          (instance-write-internal
 509                           .pv. instance-slots 1 nv
 510                           (setf (slot-value instance slot-name) nv))))))))
 511     (setf (getf (getf initargs :plist) :slot-name-lists)
 512           (list nil (list nil slot-name)))
 513     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 514     (list* :method-spec `(writer-method ,class-name ,slot-name)
 515            initargs)))
 516
 517 (defun make-std-boundp-method-function (class-name slot-name)
 518   (let* ((pv-table-symbol (gensym))
 519          (initargs (copy-tree
 520                     (make-method-function
 521                      (lambda (instance)
 522                        (pv-binding1 (.pv. .calls.
 523                                           (symbol-value pv-table-symbol)
 524                                           (instance) (instance-slots))
 525                           (instance-boundp-internal
 526                            .pv. instance-slots 1
 527                            (slot-boundp instance slot-name))))))))
 528     (setf (getf (getf initargs :plist) :slot-name-lists)
 529           (list (list nil slot-name)))
 530     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 531     (list* :method-spec `(boundp-method ,class-name ,slot-name)
 532            initargs)))
 533
 534 (defun initialize-internal-slot-gfs (slot-name &optional type)
 535   (macrolet ((frob (type name-fun add-fun ll)
 536                `(when (or (null type) (eq type ',type))
 537                  (let* ((name (,name-fun slot-name))
 538                         (gf (ensure-generic-function name
 539                                                      :lambda-list ',ll))
 540                         (methods (generic-function-methods gf)))
 541                    (when (or (null methods)
 542                              (plist-value gf 'slot-missing-method))
 543                      (setf (plist-value gf 'slot-missing-method) nil)
 544                      (,add-fun *the-class-slot-object* gf slot-name))))))
 545     (frob reader slot-reader-name add-reader-method (object))
 546     (frob writer slot-writer-name add-writer-method (new-value object))
 547     (frob boundp slot-boundp-name add-boundp-method (object))))