tests: Avoid nonsensical classes and methods in deprecation.impure.lisp
[sbcl.git] / src / pcl / env.lisp
bloba4a51bf3199bd978a906e13fdc0662015697c4de
1 ;;;; basic environmental stuff
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
17 ;;;; Use and copying of this software and preparation of derivative works based
18 ;;;; upon this software are permitted. Any distribution of this software or
19 ;;;; derivative works must comply with all applicable United States export
20 ;;;; control laws.
21 ;;;;
22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
23 ;;;; warranty about the software, its performance or its conformity to any
24 ;;;; specification.
26 (in-package "SB-PCL")
28 ;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
29 ;;; exported from PCL, but it looks as though it might be useful,
30 ;;; so I don't want to just delete it. Perhaps it should go in
31 ;;; a "contrib" directory eventually?
34 (defun parse-method-or-spec (spec &optional (errorp t))
35 (let (gf method name temp)
36 (if (method-p spec)
37 (setq method spec
38 gf (method-generic-function method)
39 temp (and gf (generic-function-name gf))
40 name (if temp
41 (make-method-spec temp
42 (method-qualifiers method)
43 (unparse-specializers
44 (method-specializers method)))
45 (make-symbol (format nil "~S" method))))
46 (let ((gf-spec (car spec)))
47 (multiple-value-bind (quals specls)
48 (parse-defmethod (cdr spec))
49 (and (setq gf (and (or errorp (fboundp gf-spec))
50 (gdefinition gf-spec)))
51 (let ((nreq (compute-discriminating-function-arglist-info gf)))
52 (setq specls (append (parse-specializers specls)
53 (make-list (- nreq (length specls))
54 :initial-element
55 *the-class-t*)))
56 (and
57 (setq method (get-method gf quals specls errorp))
58 (setq name
59 (make-method-spec
60 gf-spec quals (unparse-specializers specls)))))))))
61 (values gf method name)))
63 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
64 ;;; method-spec should be a list like:
65 ;;; (<generic-function-spec> qualifiers* (specializers*))
66 ;;; where <generic-function-spec> should be either a symbol or a list
67 ;;; of (SETF <symbol>).
68 ;;;
69 ;;; For example, to trace the method defined by:
70 ;;;
71 ;;; (defmethod foo ((x spaceship)) 'ss)
72 ;;;
73 ;;; You should say:
74 ;;;
75 ;;; (trace-method '(foo (spaceship)))
76 ;;;
77 ;;; You can also provide a method object in the place of the method
78 ;;; spec, in which case that method object will be traced.
79 ;;;
80 ;;; For UNTRACE-METHOD, if an argument is given, that method is untraced.
81 ;;; If no argument is given, all traced methods are untraced.
82 (defclass traced-method (method)
83 ((method :initarg :method)
84 (function :initarg :function
85 :reader method-function)
86 (generic-function :initform nil
87 :accessor method-generic-function)))
89 (defmethod method-lambda-list ((m traced-method))
90 (with-slots (method) m (method-lambda-list method)))
92 (defmethod method-specializers ((m traced-method))
93 (with-slots (method) m (method-specializers method)))
95 (defmethod method-qualifiers ((m traced-method))
96 (with-slots (method) m (method-qualifiers method)))
98 (defmethod accessor-method-slot-name ((m traced-method))
99 (with-slots (method) m (accessor-method-slot-name method)))
101 (defvar *traced-methods* ())
103 (defun trace-method (spec &rest options)
104 (multiple-value-bind (gf omethod name)
105 (parse-method-or-spec spec)
106 (let* ((tfunction (trace-method-internal (method-function omethod)
107 name
108 options))
109 (tmethod (make-instance 'traced-method
110 :method omethod
111 :function tfunction)))
112 (remove-method gf omethod)
113 (add-method gf tmethod)
114 (pushnew tmethod *traced-methods*)
115 tmethod)))
117 (defun untrace-method (&optional spec)
118 (flet ((untrace-1 (m)
119 (let ((gf (method-generic-function m)))
120 (when gf
121 (remove-method gf m)
122 (add-method gf (slot-value m 'method))
123 (setq *traced-methods* (remove m *traced-methods*))))))
124 (if (not (null spec))
125 (multiple-value-bind (gf method)
126 (parse-method-or-spec spec)
127 (declare (ignore gf))
128 (if (memq method *traced-methods*)
129 (untrace-1 method)
130 (error "~S is not a traced method?" method)))
131 (dolist (m *traced-methods*) (untrace-1 m)))))
133 (defun trace-method-internal (ofunction name options)
134 (eval `(untrace ,name))
135 (setf (fdefinition name) ofunction)
136 (eval `(trace ,name ,@options))
137 (fdefinition name))
141 ;;;; Helper for slightly newer trace implementation, based on
142 ;;;; breakpoint stuff. The above is potentially still useful, so it's
143 ;;;; left in, commented.
145 ;;; (this turned out to be a roundabout way of doing things)
146 (defun list-all-maybe-method-names (gf)
147 (let (result)
148 (dolist (method (generic-function-methods gf) (nreverse result))
149 (let ((spec (nth-value 2 (parse-method-or-spec method))))
150 (push spec result)
151 (push (list* 'fast-method (cdr spec)) result)))))
154 ;;;; MAKE-LOAD-FORM
156 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
157 ;; shiny new generic function.
158 (fmakunbound 'make-load-form)
159 (defgeneric make-load-form (object &optional environment))
161 (defun !incorporate-cross-compiled-methods (gf-name &key except)
162 (assert (generic-function-p (fdefinition gf-name)))
163 (loop for (predicate fmf specializer qualifier lambda-list source-loc)
164 ;; Reversing installs less-specific methods first,
165 ;; so that if perchance we crash mid way through the loop,
166 ;; there is (hopefully) at least some installed method that works.
167 across (nreverse (remove-if (lambda (x) (member x except))
168 (cdr (assoc gf-name *!trivial-methods*))
169 :key #'third))
170 do (multiple-value-bind (specializers arg-info)
171 (ecase gf-name
172 (print-object
173 (values (list (find-class specializer) (find-class t))
174 '(:arg-info (2))))
175 (make-load-form
176 (values (list (find-class specializer))
177 '(:arg-info (1 . t)))))
178 (load-defmethod
179 'standard-method gf-name
180 (if qualifier (list qualifier)) specializers lambda-list
181 `(:function
182 ,(let ((mf (%make-method-function fmf nil)))
183 (sb-mop:set-funcallable-instance-function
184 mf (method-function-from-fast-function fmf arg-info))
186 plist ,arg-info simple-next-method-call t)
187 source-loc))))
188 (!incorporate-cross-compiled-methods 'make-load-form :except '(layout))
190 (defmethod make-load-form ((class class) &optional env)
191 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
192 ;; doesn't matter while all our environments are the same...
193 (declare (ignore env))
194 (let ((name (class-name class)))
195 (if (and name (eq (find-class name nil) class))
196 `(find-class ',name)
197 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
198 class))))
200 (defmethod make-load-form ((object layout) &optional env)
201 (declare (ignore env))
202 (if (layout-for-std-class-p object)
203 (let ((pname (classoid-proper-name (layout-classoid object))))
204 (unless pname
205 (error "can't dump wrapper for anonymous class:~% ~S"
206 (layout-classoid object)))
207 `(classoid-layout (find-classoid ',pname)))
208 :ignore-it))
210 ;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled.
211 (defun dont-know-how-to-dump (object)
212 (error "~@<don't know how to dump ~S (default ~S method called).~>"
213 object 'make-load-form))
215 (macrolet ((define-default-make-load-form-method (class)
216 `(defmethod make-load-form ((object ,class) &optional env)
217 (declare (ignore env))
218 (dont-know-how-to-dump object))))
219 (define-default-make-load-form-method structure-object)
220 (define-default-make-load-form-method standard-object)
221 (define-default-make-load-form-method condition))
223 sb-impl::
224 (defmethod make-load-form ((host (eql *physical-host*)) &optional env)
225 (declare (ignore env))
226 '*physical-host*)