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