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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Jun 1 18:37:55 1992 UTC (21 years, 10 months ago) by ram
Branch: MAIN
Branch point for: patch_16
Changes since 1.3: +40 -49 lines
This is March-92-PCL-2a.
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 (defun pcl-arglist (function &rest other-args)
36 (let ((defn nil))
37 (cond ((and (fsc-instance-p function)
38 (generic-function-p function))
39 (generic-function-pretty-arglist function))
40 ((and (symbolp function)
41 (fboundp function)
42 (setq defn (symbol-function function))
43 (fsc-instance-p defn)
44 (generic-function-p defn))
45 (generic-function-pretty-arglist defn))
46 (t (apply (original-definition 'sys::arglist)
47 function other-args)))))
48
49 (redefine-function 'sys::arglist 'pcl-arglist)
50
51 )
52
53
54 ;;;
55 ;;;
56 ;;;
57
58 (defgeneric describe-object (object stream))
59
60 #-Genera
61 (progn
62
63 (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
64 (let (#+Lispm (*describe-no-complaints* no-complaints))
65 #+Lispm (declare (special *describe-no-complaints*))
66 (describe-object object *standard-output*)
67 (values)))
68
69 (defmethod describe-object (object stream)
70 (let ((*standard-output* stream))
71 (funcall (original-definition 'describe) object)))
72
73 (redefine-function 'describe 'pcl-describe)
74
75 )
76
77 (defmethod describe-object ((object slot-object) stream)
78 (let* ((class (class-of object))
79 (slotds (slots-to-inspect class object))
80 (max-slot-name-length 0)
81 (instance-slotds ())
82 (class-slotds ())
83 (other-slotds ()))
84 (flet ((adjust-slot-name-length (name)
85 (setq max-slot-name-length
86 (max max-slot-name-length
87 (length (the string (symbol-name name))))))
88 (describe-slot (name value &optional (allocation () alloc-p))
89 (if alloc-p
90 (format stream
91 "~% ~A ~S ~VT ~S"
92 name allocation (+ max-slot-name-length 7) value)
93 (format stream
94 "~% ~A~VT ~S"
95 name max-slot-name-length value))))
96 ;; Figure out a good width for the slot-name column.
97 (dolist (slotd slotds)
98 (adjust-slot-name-length (slot-definition-name slotd))
99 (case (slot-definition-allocation slotd)
100 (:instance (push slotd instance-slotds))
101 (:class (push slotd class-slotds))
102 (otherwise (push slotd other-slotds))))
103 (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
104 (format stream "~%~S is an instance of class ~S:" object class)
105
106 (when instance-slotds
107 (format stream "~% The following slots have :INSTANCE allocation:")
108 (dolist (slotd (nreverse instance-slotds))
109 (describe-slot (slot-definition-name slotd)
110 (slot-value-or-default object (slot-definition-name slotd)))))
111
112 (when class-slotds
113 (format stream "~% The following slots have :CLASS allocation:")
114 (dolist (slotd (nreverse class-slotds))
115 (describe-slot (slot-definition-name slotd)
116 (slot-value-or-default object (slot-definition-name slotd)))))
117
118 (when other-slotds
119 (format stream "~% The following slots have allocation as shown:")
120 (dolist (slotd (nreverse other-slotds))
121 (describe-slot (slot-definition-name slotd)
122 (slot-value-or-default object (slot-definition-name slotd))
123 (slot-definition-allocation slotd))))
124 (values))))
125
126 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
127 (class-slots class))
128
129 (defmethod describe-object ((fun standard-generic-function) stream)
130 (format stream "~A is a generic function.~%" fun)
131 (format stream "Its arguments are:~% ~S~%"
132 (generic-function-pretty-arglist fun))
133 (format stream "Its methods are:")
134 (dolist (meth (generic-function-methods fun))
135 (format stream "~2%**** ~{~S ~}~:S =>~%"
136 (method-qualifiers meth)
137 (unparse-specializers meth))
138 (describe-object (method-function meth) stream)))
139
140 ;;;
141 ;;;
142 ;;;
143 (defvar *describe-classes-as-objects-p* nil)
144
145 (defmethod describe-object ((class class) stream)
146 (flet ((pretty-class (c) (or (class-name c) c)))
147 (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
148 (ft "~&~S is a class, it is an instance of ~S.~%"
149 class (pretty-class (class-of class)))
150 (let ((name (class-name class)))
151 (if name
152 (if (eq class (find-class name nil))
153 (ft "Its proper name is ~S.~%" name)
154 (ft "Its name is ~S, but this is not a proper name.~%" name))
155 (ft "It has no name (the name is NIL).~%")))
156 (ft "The direct superclasses are: ~:S, and the direct~%~
157 subclasses are: ~:S. The class precedence list is:~%~S~%~
158 There are ~D methods specialized for this class."
159 (mapcar #'pretty-class (class-direct-superclasses class))
160 (mapcar #'pretty-class (class-direct-subclasses class))
161 (mapcar #'pretty-class (class-precedence-list class))
162 (length (specializer-direct-methods class)))))
163 (when *describe-classes-as-objects-p*
164 (call-next-method)))
165
166
167
168 ;;;
169 ;;; trace-method and untrace-method accept method specs as arguments. A
170 ;;; method-spec should be a list like:
171 ;;; (<generic-function-spec> qualifiers* (specializers*))
172 ;;; where <generic-function-spec> should be either a symbol or a list
173 ;;; of (SETF <symbol>).
174 ;;;
175 ;;; For example, to trace the method defined by:
176 ;;;
177 ;;; (defmethod foo ((x spaceship)) 'ss)
178 ;;;
179 ;;; You should say:
180 ;;;
181 ;;; (trace-method '(foo (spaceship)))
182 ;;;
183 ;;; You can also provide a method object in the place of the method
184 ;;; spec, in which case that method object will be traced.
185 ;;;
186 ;;; For untrace-method, if an argument is given, that method is untraced.
187 ;;; If no argument is given, all traced methods are untraced.
188 ;;;
189 (defclass traced-method (method)
190 ((method :initarg :method)
191 (function :initarg :function
192 :reader method-function)
193 (generic-function :initform nil
194 :accessor method-generic-function)))
195
196 (defmethod method-lambda-list ((m traced-method))
197 (with-slots (method) m (method-lambda-list method)))
198
199 (defmethod method-specializers ((m traced-method))
200 (with-slots (method) m (method-specializers method)))
201
202 (defmethod method-qualifiers ((m traced-method))
203 (with-slots (method) m (method-qualifiers method)))
204
205 (defmethod method-qualifiers ((m traced-method))
206 (with-slots (method) m (method-qualifiers method)))
207
208 (defmethod accessor-method-slot-name ((m traced-method))
209 (with-slots (method) m (accessor-method-slot-name method)))
210
211 (defvar *traced-methods* ())
212
213 (defun trace-method (spec &rest options)
214 (multiple-value-bind (gf omethod name)
215 (parse-method-or-spec spec)
216 (let* ((tfunction (trace-method-internal (method-function omethod)
217 name
218 options))
219 (tmethod (make-instance 'traced-method
220 :method omethod
221 :function tfunction)))
222 (remove-method gf omethod)
223 (add-method gf tmethod)
224 (pushnew tmethod *traced-methods*)
225 tmethod)))
226
227 (defun untrace-method (&optional spec)
228 (flet ((untrace-1 (m)
229 (let ((gf (method-generic-function m)))
230 (when gf
231 (remove-method gf m)
232 (add-method gf (slot-value m 'method))
233 (setq *traced-methods* (remove m *traced-methods*))))))
234 (if (not (null spec))
235 (multiple-value-bind (gf method)
236 (parse-method-or-spec spec)
237 (declare (ignore gf))
238 (if (memq method *traced-methods*)
239 (untrace-1 method)
240 (error "~S is not a traced method?" method)))
241 (dolist (m *traced-methods*) (untrace-1 m)))))
242
243 (defun trace-method-internal (ofunction name options)
244 (eval `(untrace ,name))
245 (setf (symbol-function name) ofunction)
246 (eval `(trace ,name ,@options))
247 (symbol-function name))
248
249
250
251
252 ;(defun compile-method (spec)
253 ; (multiple-value-bind (gf method name)
254 ; (parse-method-or-spec spec)
255 ; (declare (ignore gf))
256 ; (compile name (method-function method))
257 ; (setf (method-function method) (symbol-function name))))
258
259 (defmacro undefmethod (&rest args)
260 #+(or (not :lucid) :lcl3.0)
261 (declare (arglist name {method-qualifier}* specializers))
262 `(undefmethod-1 ',args))
263
264 (defun undefmethod-1 (args)
265 (multiple-value-bind (gf method)
266 (parse-method-or-spec args)
267 (when (and gf method)
268 (remove-method gf method)
269 method)))
270
271
272 (pushnew :pcl *features*)
273 (pushnew :portable-commonloops *features*)
274 (pushnew :pcl-structures *features*)

  ViewVC Help
Powered by ViewVC 1.1.5