1 ;;;; things which the main SBCL compiler needs to know about the
2 ;;;; implementation of CLOS
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
9 ;;;; This software is part of the SBCL system. See the README file for more
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
18 ;;;; copyright information from original PCL sources:
20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
21 ;;;; All rights reserved.
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
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
34 ;;;; very low-level representation of instances with meta-class
37 (defknown sb-pcl
::pcl-instance-p
(t) boolean
38 (movable foldable flushable explicit-check
))
40 (deftransform sb-pcl
::pcl-instance-p
((object))
41 (let* ((otype (lvar-type object
))
42 (std-obj (specifier-type 'sb-pcl
::std-object
)))
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
)
48 `(typep (layout-of object
) 'sb-pcl
::wrapper
)))))
50 (define-source-context defmethod
(name &rest stuff
)
51 (let ((arg-pos (position-if #'listp stuff
)))
53 `(defmethod ,name
,@(subseq stuff
0 arg-pos
)
55 (nth-value 2 (sb-pcl::parse-specialized-lambda-list
57 (error () "<illegal syntax>")))
58 `(defmethod ,name
"<illegal syntax>"))))
60 (defvar sb-pcl
::*internal-pcl-generalized-fun-name-symbols
* nil
)
62 (defmacro define-internal-pcl-function-name-syntax
(name &body body
)
64 (define-function-name-syntax ,name
,@body
)
65 (pushnew ',name sb-pcl
::*internal-pcl-generalized-fun-name-symbols
*)))
67 (define-internal-pcl-function-name-syntax sb-pcl
::class-predicate
(list)
69 (destructuring-bind (name &rest rest
) (cdr list
)
70 (when (and (symbolp name
)
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
))
82 (define-internal-pcl-function-name-syntax sb-pcl
::fast-method
(list)
83 (valid-function-name-p (cadr list
)))
85 (define-internal-pcl-function-name-syntax sb-pcl
::slow-method
(list)
86 (valid-function-name-p (cadr list
)))
88 (define-internal-pcl-function-name-syntax sb-pcl
::ctor
(list)
89 (valid-function-name-p (cadr list
)))
91 (defun sb-pcl::random-documentation
(name type
)
92 (cdr (assoc type
(info :random-documentation
:stuff name
))))
94 (defun sb-pcl::set-random-documentation
(name type new-value
)
95 (let ((pair (assoc type
(info :random-documentation
:stuff name
))))
97 (setf (cdr pair
) new-value
)
98 (push (cons type new-value
)
99 (info :random-documentation
:stuff name
))))
102 (defsetf sb-pcl
::random-documentation sb-pcl
::set-random-documentation
)