/[cmucl]/src/pcl/env.lisp
ViewVC logotype

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Oct 19 17:22:23 1991 UTC (22 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.2: +3 -39 lines
Merged with latest PCL version.
1 ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27 ;;; Basic environmental stuff.
28 ;;;
29
30 (in-package 'pcl)
31
32 #+Lucid
33 (progn
34
35 (defvar *old-arglist*)
36
37 (defun pcl-arglist (function &rest other-args)
38 (let ((defn nil))
39 (cond ((and (fsc-instance-p function)
40 (generic-function-p function))
41 (generic-function-pretty-arglist function))
42 ((and (symbolp function)
43 (fboundp function)
44 (setq defn (symbol-function function))
45 (fsc-instance-p defn)
46 (generic-function-p defn))
47 (generic-function-pretty-arglist defn))
48 (t (apply *old-arglist* function other-args)))))
49
50 (eval-when (eval load)
51 (unless (boundp '*old-arglist*)
52 (setq *old-arglist* (symbol-function 'sys::arglist))
53 (setf (symbol-function 'sys::arglist) #'pcl-arglist)))
54
55 )
56
57
58 ;;;
59 ;;;
60 ;;;
61
62 (defgeneric describe-object (object stream))
63
64 #-Genera (progn
65
66 #-cmu
67 (defvar *old-describe* ())
68
69 #-cmu
70 (eval-when (load)
71 (unless *old-describe* (setq *old-describe* (symbol-function 'describe)))
72 (setf (symbol-function 'describe)
73 #+Lispm
74 #'(lambda (object &optional no-complaints)
75 (let ((*describe-no-complaints* no-complaints))
76 (declare (special *describe-no-complaints*))
77 (describe-object object *standard-output*)
78 (values)))
79 #-Lispm
80 #'(lambda (object)
81 (describe-object object *standard-output*)
82 (values))))
83
84 (defmethod describe-object (object stream)
85 #-cmu
86 (let ((*standard-output* stream))
87 (funcall *old-describe* object))
88 #+cmu
89 (describe object stream))
90
91 (defmethod describe-object ((object standard-object) stream)
92 (let* ((class (class-of object))
93 (slotds (slots-to-inspect class object))
94 (max-slot-name-length 0)
95 (instance-slotds ())
96 (class-slotds ())
97 (other-slotds ()))
98 (flet ((adjust-slot-name-length (name)
99 (setq max-slot-name-length
100 (max max-slot-name-length
101 (length (the string (symbol-name name))))))
102 (describe-slot (name value &optional (allocation () alloc-p))
103 (if alloc-p
104 (format stream
105 "~% ~A ~S ~VT ~S"
106 name allocation (+ max-slot-name-length 7) value)
107 (format stream
108 "~% ~A~VT ~S"
109 name max-slot-name-length value))))
110 ;; Figure out a good width for the slot-name column.
111 (dolist (slotd slotds)
112 (adjust-slot-name-length (slotd-name slotd))
113 (case (slotd-allocation slotd)
114 (:instance (push slotd instance-slotds))
115 (:class (push slotd class-slotds))
116 (otherwise (push slotd other-slotds))))
117 (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
118 (format stream "~%~S is an instance of class ~S:" object class)
119
120 (when instance-slotds
121 (format stream "~% The following slots have :INSTANCE allocation:")
122 (dolist (slotd (nreverse instance-slotds))
123 (describe-slot (slotd-name slotd)
124 (slot-value-or-default object (slotd-name slotd)))))
125
126 (when class-slotds
127 (format stream "~% The following slots have :CLASS allocation:")
128 (dolist (slotd (nreverse class-slotds))
129 (describe-slot (slotd-name slotd)
130 (slot-value-or-default object (slotd-name slotd)))))
131
132 (when other-slotds
133 (format stream "~% The following slots have allocation as shown:")
134 (dolist (slotd (nreverse other-slotds))
135 (describe-slot (slotd-name slotd)
136 (slot-value-or-default object (slotd-name slotd))
137 (slotd-allocation slotd))))
138 (values))))
139
140 #+cmu
141 (defmethod describe-object ((fun standard-generic-function) stream)
142 (format stream "~A is a generic function.~%" fun)
143 (format stream "Its arguments are:~% ~S~%"
144 (generic-function-pretty-arglist fun))
145 (format stream "Its methods are:")
146 (dolist (meth (generic-function-methods fun))
147 (format stream "~2%**** ~{~S ~}~:S =>~%"
148 (method-qualifiers meth)
149 (unparse-specializers meth))
150 (describe-object (method-function meth) stream)))
151
152
153 (defmethod slots-to-inspect ((class std-class) (object standard-object))
154 (class-slots class))
155
156 ;;;
157 ;;;
158 ;;;
159 (defmethod describe-object ((class class) stream)
160 (flet ((pretty-class (c) (or (class-name c) c)))
161 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
162 (ft "~&~S is a class, it is an instance of ~S.~%"
163 class (pretty-class (class-of class)))
164 (let ((name (class-name class)))
165 (if name
166 (if (eq class (find-class name nil))
167 (ft "Its proper name is ~S.~%" name)
168 (ft "Its name is ~S, but this is not a proper name.~%" name))
169 (ft "It has no name (the name is NIL).~%")))
170 (ft "The direct superclasses are: ~:S, and the direct~%~
171 subclasses are: ~:S. The class precedence list is:~%~S~%~
172 There are ~D methods specialized for this class."
173 (mapcar #'pretty-class (class-direct-superclasses class))
174 (mapcar #'pretty-class (class-direct-subclasses class))
175 (mapcar #'pretty-class (class-precedence-list class))
176 (length (specializer-methods class))))))
177
178
179
180 ;;;
181 ;;; trace-method and untrace-method accept method specs as arguments. A
182 ;;; method-spec should be a list like:
183 ;;; (<generic-function-spec> qualifiers* (specializers*))
184 ;;; where <generic-function-spec> should be either a symbol or a list
185 ;;; of (SETF <symbol>).
186 ;;;
187 ;;; For example, to trace the method defined by:
188 ;;;
189 ;;; (defmethod foo ((x spaceship)) 'ss)
190 ;;;
191 ;;; You should say:
192 ;;;
193 ;;; (trace-method '(foo (spaceship)))
194 ;;;
195 ;;; You can also provide a method object in the place of the method
196 ;;; spec, in which case that method object will be traced.
197 ;;;
198 ;;; For untrace-method, if an argument is given, that method is untraced.
199 ;;; If no argument is given, all traced methods are untraced.
200 ;;;
201 (defclass traced-method (method)
202 ((method :initarg :method)
203 (function :initarg :function
204 :reader method-function)
205 (generic-function :initform nil
206 :accessor method-generic-function)))
207
208 (defmethod method-lambda-list ((m traced-method))
209 (with-slots (method) m (method-lambda-list method)))
210
211 (defmethod method-specializers ((m traced-method))
212 (with-slots (method) m (method-specializers method)))
213
214 (defmethod method-qualifiers ((m traced-method))
215 (with-slots (method) m (method-qualifiers method)))
216
217 (defmethod method-qualifiers ((m traced-method))
218 (with-slots (method) m (method-qualifiers method)))
219
220 (defmethod accessor-method-slot-name ((m traced-method))
221 (with-slots (method) m (accessor-method-slot-name method)))
222
223 (defvar *traced-methods* ())
224
225 (defun trace-method (spec &rest options)
226 (multiple-value-bind (gf omethod name)
227 (parse-method-or-spec spec)
228 (let* ((tfunction (trace-method-internal (method-function omethod)
229 name
230 options))
231 (tmethod (make-instance 'traced-method
232 :method omethod
233 :function tfunction)))
234 (remove-method gf omethod)
235 (add-method gf tmethod)
236 (pushnew tmethod *traced-methods*)
237 tmethod)))
238
239 (defun untrace-method (&optional spec)
240 (flet ((untrace-1 (m)
241 (let ((gf (method-generic-function m)))
242 (when gf
243 (remove-method gf m)
244 (add-method gf (slot-value m 'method))
245 (setq *traced-methods* (remove m *traced-methods*))))))
246 (if (not (null spec))
247 (multiple-value-bind (gf method)
248 (parse-method-or-spec spec)
249 (declare (ignore gf))
250 (if (memq method *traced-methods*)
251 (untrace-1 method)
252 (error "~S is not a traced method?" method)))
253 (dolist (m *traced-methods*) (untrace-1 m)))))
254
255 (defun trace-method-internal (ofunction name options)
256 (eval `(untrace ,name))
257 (setf (symbol-function name) ofunction)
258 (eval `(trace ,name ,@options))
259 (symbol-function name))
260
261
262
263
264 ;(defun compile-method (spec)
265 ; (multiple-value-bind (gf method name)
266 ; (parse-method-or-spec spec)
267 ; (declare (ignore gf))
268 ; (compile name (method-function method))
269 ; (setf (method-function method) (symbol-function name))))
270
271 (defmacro undefmethod (&rest args)
272 #+(or (not :lucid) :lcl3.0)
273 (declare (arglist name {method-qualifier}* specializers))
274 `(undefmethod-1 ',args))
275
276 (defun undefmethod-1 (args)
277 (multiple-value-bind (gf method)
278 (parse-method-or-spec args)
279 (when (and gf method)
280 (remove-method gf method)
281 method)))
282
283 ); #-genera progn

  ViewVC Help
Powered by ViewVC 1.1.5