0.8.21.1:
[sbcl.git] / 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 (defknown sb-pcl::pcl-instance-p (t) boolean
38   (movable foldable flushable explicit-check))
39
40 (deftransform sb-pcl::pcl-instance-p ((object))
41   (let* ((otype (lvar-type object))
42          (std-obj (specifier-type 'sb-pcl::std-object)))
43     (cond
44       ;; Flush tests whose result is known at compile time.
45       ((csubtypep otype std-obj) t)
46       ((not (types-equal-or-intersect otype std-obj)) nil)
47       (t
48        `(typep (layout-of object) 'sb-pcl::wrapper)))))
49
50 (define-source-context defmethod (name &rest stuff)
51   (let ((arg-pos (position-if #'listp stuff)))
52     (if arg-pos
53         `(defmethod ,name ,@(subseq stuff 0 arg-pos)
54            ,(handler-case
55                 (nth-value 2 (sb-pcl::parse-specialized-lambda-list
56                               (elt stuff arg-pos)))
57               (error () "<illegal syntax>")))
58         `(defmethod ,name "<illegal syntax>"))))
59
60 (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
61
62 (defmacro define-internal-pcl-function-name-syntax (name &body body)
63   `(progn
64      (define-function-name-syntax ,name ,@body)
65      (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*)))
66
67 (define-internal-pcl-function-name-syntax sb-pcl::class-predicate (list)
68   (when (cdr list)
69     (destructuring-bind (name &rest rest) (cdr list)
70       (when (and (symbolp name)
71                  (null rest))
72         (values t name)))))
73
74 (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list)
75   (when (= (length list) 4)
76     (destructuring-bind (class slot rwb) (cdr list)
77       (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp))
78                  (symbolp slot)
79                  (symbolp class))
80         (values t slot)))))
81
82 (define-internal-pcl-function-name-syntax sb-pcl::fast-method (list)
83   (valid-function-name-p (cadr list)))
84
85 (define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
86   (valid-function-name-p (cadr list)))
87
88 (define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
89   (valid-function-name-p (cadr list)))
90
91 (defun sb-pcl::random-documentation (name type)
92   (cdr (assoc type (info :random-documentation :stuff name))))
93
94 (defun sb-pcl::set-random-documentation (name type new-value)
95   (let ((pair (assoc type (info :random-documentation :stuff name))))
96     (if pair
97         (setf (cdr pair) new-value)
98         (push (cons type new-value)
99               (info :random-documentation :stuff name))))
100   new-value)
101
102 (defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation)