src/pcl/fixup.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
  26 (!fix-early-generic-functions)
  27 (!fix-ensure-accessor-specializers)
  28 (compute-standard-slot-locations)
  29 (dolist (s '(condition function structure-object))
  30   (dohash ((k v) (classoid-subclasses (find-classoid s)))
  31     (declare (ignore v))
  32     (find-class (classoid-name k))))
  33 (setq **boot-state** 'complete)
  34
  35 (defun print-std-instance (instance stream depth)
  36   (declare (ignore depth))
  37   (print-object instance stream))
  38
  39 (setf (compiler-macro-function 'slot-value) nil)
  40 (setf (compiler-macro-function 'set-slot-value) nil)
  41
  42 (in-package "SB-C")
  43
  44 (defknown slot-value (t symbol) t (any))
  45 (defknown (slot-boundp slot-exists-p) (t symbol) boolean)
  46 (defknown sb-pcl::set-slot-value (t symbol t) t (any))
  47
  48 (defknown find-class (symbol &optional t lexenv-designator)
  49   (or class null))
  50 (defknown class-of (t) class (flushable))
  51 (defknown class-name (class) symbol (flushable))
  52
  53 (deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
  54                           :node node)
  55   (let ((c-slot-name (lvar-value slot-name)))
  56     (if (sb-pcl::interned-symbol-p c-slot-name)
  57         (let* ((type (lvar-type object))
  58                (dd (when (structure-classoid-p type)
  59                      (find-defstruct-description
  60                       (sb-kernel::structure-classoid-name type))))
  61                (dsd (when dd
  62                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
  63           (cond (dsd
  64                  `(,(dsd-accessor-name dsd) object))
  65                 (t
  66                  (delay-ir1-transform node :constraint)
  67                  `(sb-pcl::accessor-slot-value object ',c-slot-name))))
  68         (give-up-ir1-transform "slot name is not an interned symbol"))))
  69
  70 (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
  71                                       (t (constant-arg symbol) t)
  72                                       * :node node)
  73   (let ((c-slot-name (lvar-value slot-name)))
  74     (if (sb-pcl::interned-symbol-p c-slot-name)
  75         (let* ((type (lvar-type object))
  76                (dd (when (structure-classoid-p type)
  77                      (find-defstruct-description
  78                       (sb-kernel::structure-classoid-name type))))
  79                (dsd (when dd
  80                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
  81           (cond (dsd
  82                  `(setf (,(dsd-accessor-name dsd) object) new-value))
  83                 ((policy node (= safety 3))
  84                  ;; Safe code wants to check the type, and the global
  85                  ;; accessor won't do that. Also see the comment in the
  86                  ;; compiler-macro.
  87                  (give-up-ir1-transform "cannot use optimized accessor in safe code"))
  88                 (t
  89                  (delay-ir1-transform node :constraint)
  90                  `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
  91         (give-up-ir1-transform "slot name is not an interned symbol"))))