1;;;; things which the main SBCL compiler needs to know about the
2;;;; implementation of CLOS
3;;;;
4;;;; (Our CLOS is derived from PCL, which was implemented in terms of
5;;;; portable high-level Common Lisp. But now that it no longer needs
6;;;; to be portable, we can make some special hacks to support it
7;;;; better.)
8
9;;;; This software is part of the SBCL system. See the README file for more
10;;;; information.
11
12;;;; This software is derived from software originally released by Xerox
13;;;; Corporation. Copyright and release statements follow. Later modifications
14;;;; to the software are in the public domain and are provided with
15;;;; absolutely no warranty. See the COPYING and CREDITS files for more
16;;;; information.
17
18;;;; copyright information from original PCL sources:
19;;;;
20;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
21;;;; All rights reserved.
22;;;;
23;;;; Use and copying of this software and preparation of derivative works based
24;;;; upon this software are permitted. Any distribution of this software or
25;;;; derivative works must comply with all applicable United States export
26;;;; control laws.
27;;;;
28;;;; This software is made available AS IS, and Xerox Corporation makes no
29;;;; warranty about the software, its performance or its conformity to any
30;;;; specification.
31
32(in-package "SB-C")
33
34;;;; very low-level representation of instances with meta-class
35;;;; STANDARD-CLASS
36
37(deftransform sb-pcl::pcl-instance-p ((object))
38  (let* ((otype (lvar-type object))
39         (standard-object (specifier-type 'standard-object)))
40    (cond
41      ;; Flush tests whose result is known at compile time.
42      ((csubtypep otype standard-object) t)
43      ((not (types-equal-or-intersect otype standard-object)) nil)
44      (t
45       `(sb-pcl::%pcl-instance-p object)))))
46
47(defun sb-pcl::safe-code-p (&optional env)
48  (policy (or env (make-null-lexenv)) (eql safety 3)))
49
50(declaim (ftype function sb-pcl::parse-specialized-lambda-list))
51(define-source-context defmethod (name &rest stuff)
52  (let ((arg-pos (position-if #'listp stuff)))
53    (if arg-pos
54        `(defmethod ,name ,@(subseq stuff 0 arg-pos)
55           ,(handler-case
56                (nth-value 2 (sb-pcl::parse-specialized-lambda-list
57                              (elt stuff arg-pos)))
58              (error () "<illegal syntax>")))
59        `(defmethod ,name "<illegal syntax>"))))
60
61(defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
62
63(defmacro define-internal-pcl-function-name-syntax (name (var) &body body)
64  `(progn
65     (define-function-name-syntax ,name (,var) ,@body)
66     (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*)))
67
68(define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list)
69  (when (= (length list) 4)
70    (destructuring-bind (class slot rwb) (cdr list)
71      (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp))
72                 (symbolp slot)
73                 (symbolp class))
74        (values t slot)))))
75
76(define-internal-pcl-function-name-syntax sb-pcl::fast-method (list)
77  (valid-function-name-p (cadr list)))
78
79(define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
80  (valid-function-name-p (cadr list)))
81
82(defun interned-symbol-p (x) (and (symbolp x) (symbol-package x)))
83
84(flet ((struct-accessor-p (object slot-name)
85         (let ((c-slot-name (lvar-value slot-name)))
86           (unless (interned-symbol-p c-slot-name)
87             (give-up-ir1-transform "slot name is not an interned symbol"))
88           (let* ((type (lvar-type object))
89                  (dd (when (structure-classoid-p type)
90                        (find-defstruct-description
91                         (sb-kernel::structure-classoid-name type)))))
92              (when dd
93                (find c-slot-name (dd-slots dd) :key #'dsd-name))))))
94
95  (deftransform slot-boundp ((object slot-name) (t (constant-arg symbol)) *
96                             :node node)
97    (cond ((struct-accessor-p object slot-name) t) ; always boundp
98          (t (delay-ir1-transform node :constraint)
99             `(sb-pcl::accessor-slot-boundp object ',(lvar-value slot-name)))))
100
101  (deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
102                            :node node)
103    (acond ((struct-accessor-p object slot-name)
104            `(,(dsd-accessor-name it) object))
105           (t
106            (delay-ir1-transform node :constraint)
107            `(sb-pcl::accessor-slot-value object ',(lvar-value slot-name)))))
108
109  (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
110                                        (t (constant-arg symbol) t)
111                                        * :node node)
112    (acond ((struct-accessor-p object slot-name)
113            `(setf (,(dsd-accessor-name it) object) new-value))
114           ((policy node (= safety 3))
115            ;; Safe code wants to check the type, and the global
116            ;; accessor won't do that.
117            (give-up-ir1-transform "cannot use optimized accessor in safe code"))
118           (t
119            (delay-ir1-transform node :constraint)
120            `(sb-pcl::accessor-set-slot-value object ',(lvar-value slot-name)
121                                              new-value)))))
122