src/pcl/compiler-support.lisp

   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 \f
  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)))))