Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / 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     (find-class (classoid-name k))))
32 (setq **boot-state** 'complete)
33
34 (defun print-std-instance (instance stream depth)
35   (declare (ignore depth))
36   (print-object instance stream))
37
38 (setf (compiler-macro-function 'slot-value) nil)
39 (setf (compiler-macro-function 'set-slot-value) nil)
40
41 (in-package "SB-C")
42
43 (defknown slot-value (t symbol) t (any))
44 (defknown sb-pcl::set-slot-value (t symbol t) t (any))
45
46 (deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
47                           :node node)
48   (let ((c-slot-name (lvar-value slot-name)))
49     (if (sb-pcl::interned-symbol-p c-slot-name)
50         (let* ((type (lvar-type object))
51                (dd (when (structure-classoid-p type)
52                      (find-defstruct-description
53                       (sb-kernel::structure-classoid-name type))))
54                (dsd (when dd
55                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
56           (cond (dsd
57                  `(,(dsd-accessor-name dsd) object))
58                 (t
59                  (delay-ir1-transform node :constraint)
60                  `(sb-pcl::accessor-slot-value object ',c-slot-name))))
61         (give-up-ir1-transform "slot name is not an interned symbol"))))
62
63 (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
64                                       (t (constant-arg symbol) t)
65                                       * :node node)
66   (let ((c-slot-name (lvar-value slot-name)))
67     (if (sb-pcl::interned-symbol-p c-slot-name)
68         (let* ((type (lvar-type object))
69                (dd (when (structure-classoid-p type)
70                      (find-defstruct-description
71                       (sb-kernel::structure-classoid-name type))))
72                (dsd (when dd
73                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
74           (cond (dsd
75                  `(setf (,(dsd-accessor-name dsd) object) new-value))
76                 ((policy node (= safety 3))
77                  ;; Safe code wants to check the type, and the global
78                  ;; accessor won't do that. Also see the comment in the
79                  ;; compiler-macro.
80                  (give-up-ir1-transform "cannot use optimized accessor in safe code"))
81                 (t
82                  (delay-ir1-transform node :constraint)
83                  `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
84         (give-up-ir1-transform "slot name is not an interned symbol"))))