1 ;;;; basic environmental stuff
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
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
)
38 gf
(method-generic-function method
)
39 temp
(and gf
(generic-function-name gf
))
41 (make-method-spec temp
42 (method-qualifiers method
)
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
))
57 (setq method
(get-method gf quals specls errorp
))
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>).
69 ;;; For example, to trace the method defined by:
71 ;;; (defmethod foo ((x spaceship)) 'ss)
75 ;;; (trace-method '(foo (spaceship)))
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.
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
)
109 (tmethod (make-instance 'traced-method
111 :function tfunction
)))
112 (remove-method gf omethod
)
113 (add-method gf tmethod
)
114 (pushnew tmethod
*traced-methods
*)
117 (defun untrace-method (&optional spec
)
118 (flet ((untrace-1 (m)
119 (let ((gf (method-generic-function 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
*)
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
))
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)
148 (dolist (method (generic-function-methods gf
) (nreverse result
))
149 (let ((spec (nth-value 2 (parse-method-or-spec method
))))
151 (push (list* 'fast-method
(cdr spec
)) result
)))))
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 ;; Link bootstrap-time how-to-dump-it information into the shiny new
163 (defmethod make-load-form ((obj sb-sys
:structure
!object
)
164 &optional
(env nil env-p
))
166 (sb-sys:structure
!object-make-load-form obj env
)
167 (sb-sys:structure
!object-make-load-form obj
)))
169 (defmethod make-load-form ((object layout
) &optional env
)
170 (declare (ignore env
))
171 (if (layout-for-std-class-p object
)
172 (let ((pname (classoid-proper-name (layout-classoid object
))))
174 (error "can't dump wrapper for anonymous class:~% ~S"
175 (layout-classoid object
)))
176 `(classoid-layout (find-classoid ',pname
)))
179 (defmethod make-load-form ((object structure-object
) &optional env
)
180 (declare (ignore env
))
181 (error "~@<don't know how to dump ~S (default ~S method called).~>"
182 object
'make-load-form
))
184 (defmethod make-load-form ((object standard-object
) &optional env
)
185 (declare (ignore env
))
186 (error "~@<don't know how to dump ~S (default ~S method called).~>"
187 object
'make-load-form
))
189 (defmethod make-load-form ((object condition
) &optional env
)
190 (declare (ignore env
))
191 (error "~@<don't know how to dump ~S (default ~S method called).~>"
192 object
'make-load-form
))
194 (defmethod make-load-form ((object sb-impl
::comma
) &optional env
)
195 (declare (ignore object env
))
196 :sb-just-dump-it-normally
)
198 ;; Note that it is possible to produce structure dumping code which yields
199 ;; illegal slot values in the resurrected structure, violating the assumption
200 ;; throughout the compiler that slot readers are always safe unless
201 ;; dictated otherwise by the SAFE-P flag in the DSD.
202 ;; * (defstruct S a (b (error "Must supply me") :type symbol))
203 ;; * (defmethod make-load-form ((x S) &optional e) (m-l-f-s-s x :slot-names '(a)))
204 ;; After these definitions, a dumped S will have 0 in slot B.
206 (defun make-load-form-saving-slots (object &key
(slot-names nil slot-names-p
) environment
)
207 (declare (ignore environment
))
208 (if (typep object
'structure-object
)
209 (values `(allocate-instance (find-class ',(class-name (class-of object
))))
210 `(setf ,@(sb-kernel::structure-obj-slot-saving-forms
211 object slot-names slot-names-p
)))
212 (let* ((class (class-of object
))
216 (let ((slot-name (slot-definition-name slot
)))
217 (when (if slot-names-p
218 (memq slot-name slot-names
)
219 (eq :instance
(slot-definition-allocation slot
)))
220 (list (if (slot-boundp-using-class class object slot
)
221 `(setf (slot-value ,object
',slot-name
)
222 ',(slot-value-using-class class object slot
))
223 ;; Why is this needed? Is it not specified that
224 ;; everything defaults to unbound?
225 `(slot-makunbound ,object
',slot-name
))))))
226 (class-slots class
))))
227 (values `(allocate-instance (find-class ',(class-name class
)))