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

Contents of /src/pcl/env.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26.48.2 - (hide annotations)
Sat Feb 13 01:28:04 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-2010-03-18-1300
Changes since 1.26.48.1: +30 -30 lines
Mark translatable strings; regenerate cmucl.pot and cmucl.po
1 wlott 1.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 pw 1.12
28 gerd 1.21 (file-comment
29 rtoy 1.26.48.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/env.lisp,v 1.26.48.2 2010/02/13 01:28:04 rtoy Exp $")
30 dtc 1.10 ;;;
31 wlott 1.1 ;;; Basic environmental stuff.
32     ;;;
33    
34 phg 1.7 (in-package :pcl)
35 rtoy 1.26.48.1 (intl:textdomain "cmucl")
36 wlott 1.1
37     ;;;
38     ;;;
39     ;;;
40 pw 1.13
41     ;;; ANSI compliance wants default structure printer to use #S(...) format.
42     (defmethod print-object ((object structure-object) stream)
43     (lisp::default-structure-print object stream 0))
44 pmai 1.18
45     ;;; Condition printing
46     (defmethod print-object ((object condition) stream)
47     (conditions::real-print-condition object stream))
48 wlott 1.1
49     (defgeneric describe-object (object stream))
50    
51     (defmethod describe-object (object stream)
52 pw 1.8 (describe object stream))
53 wlott 1.1
54 ram 1.4 (defmethod describe-object ((object slot-object) stream)
55 ram 1.6 (let* ((class (class-of object))
56     (slotds (slots-to-inspect class object))
57     (max-slot-name-length 0)
58     (instance-slotds ())
59     (class-slotds ())
60     (other-slotds ()))
61 wlott 1.1 (flet ((adjust-slot-name-length (name)
62 ram 1.6 (setq max-slot-name-length
63     (max max-slot-name-length
64     (length (the string (symbol-name name))))))
65     (describe-slot (name value &optional (allocation () alloc-p))
66     (if alloc-p
67     (format stream
68     "~% ~A ~S ~VT ~S"
69     name allocation (+ max-slot-name-length 7) value)
70     (format stream
71     "~% ~A~VT ~S"
72     name max-slot-name-length value))))
73 wlott 1.1 ;; Figure out a good width for the slot-name column.
74 ram 1.6 (dolist (slotd slotds)
75     (adjust-slot-name-length (slot-definition-name slotd))
76     (case (slot-definition-allocation slotd)
77     (:instance (push slotd instance-slotds))
78 gerd 1.19 (:class (push slotd class-slotds))
79 ram 1.6 (otherwise (push slotd other-slotds))))
80     (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
81 rtoy 1.26.48.2 (format stream _"~%~S is an instance of class ~S:" object class)
82 wlott 1.1
83     (when instance-slotds
84 rtoy 1.26.48.2 (format stream _"~% The following slots have :INSTANCE allocation:")
85 ram 1.6 (dolist (slotd (nreverse instance-slotds))
86     (describe-slot (slot-definition-name slotd)
87     (slot-value-or-default object (slot-definition-name slotd)))))
88 wlott 1.1
89     (when class-slotds
90 rtoy 1.26.48.2 (format stream _"~% The following slots have :CLASS allocation:")
91 ram 1.6 (dolist (slotd (nreverse class-slotds))
92     (describe-slot (slot-definition-name slotd)
93     (slot-value-or-default object (slot-definition-name slotd)))))
94 wlott 1.1
95 ram 1.6 (when other-slotds
96 rtoy 1.26.48.2 (format stream _"~% The following slots have allocation as shown:")
97 ram 1.6 (dolist (slotd (nreverse other-slotds))
98     (describe-slot (slot-definition-name slotd)
99     (slot-value-or-default object (slot-definition-name slotd))
100     (slot-definition-allocation slotd))))
101 wlott 1.1 (values))))
102 ram 1.2
103 ram 1.4 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
104     (class-slots class))
105    
106 ram 1.6 (defvar *describe-metaobjects-as-objects-p* nil)
107 ram 1.5
108 gerd 1.20 (defun method-specialized-lambda-list (method)
109     (loop with specializers = (unparse-specializers method)
110     for elt in (method-lambda-list method)
111     collect (if specializers
112     (list elt (pop specializers))
113     elt)))
114    
115 gerd 1.17 (defmethod describe-object ((gf standard-generic-function) stream)
116 rtoy 1.26.48.2 (format stream _"~A is a generic function.~%" gf)
117 gerd 1.17 (let* ((gf-name (generic-function-name gf))
118     (doc (documentation gf-name 'function)))
119 rtoy 1.26.48.2 (format stream _"Its lambda-list is:~% ~S~%"
120 gerd 1.20 (generic-function-lambda-list gf))
121 gerd 1.17 (when doc
122 rtoy 1.26.48.2 (format stream _"Generic function documentation:~% ~s~%" doc))
123     (format stream _"Its methods are:~%")
124 gerd 1.17 (loop for method in (generic-function-methods gf) and i from 1
125     as doc = (plist-value method 'documentation) do
126     (format stream " ~d: ~a ~@[~{~s ~}~]~:s~%"
127     i gf-name (method-qualifiers method)
128 gerd 1.20 (method-specialized-lambda-list method))
129 gerd 1.17 (when doc
130 rtoy 1.26.48.2 (format stream _" Method documentation: ~s~%" doc)))
131 gerd 1.17 (when *describe-metaobjects-as-objects-p*
132     (call-next-method))))
133 ram 1.2
134 wlott 1.1 ;;;
135     ;;;
136     ;;;
137     (defmethod describe-object ((class class) stream)
138     (flet ((pretty-class (c) (or (class-name c) c)))
139     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
140 rtoy 1.26.48.2 (ft _"~&~@<~S is a class, it is an instance of ~S.~@:>~%"
141 ram 1.6 class (pretty-class (class-of class)))
142 wlott 1.1 (let ((name (class-name class)))
143 ram 1.6 (if name
144     (if (eq class (find-class name nil))
145 rtoy 1.26.48.2 (ft _"Its proper name is ~S.~%" name)
146     (ft _"Its name is ~S, but this is not a proper name.~%" name))
147     (ft _"It has no name (the name is NIL).~%")))
148     (ft _"The direct superclasses are: ~:S, and the direct~%~
149 gerd 1.25 subclasses are: ~:S. The class is ~:[not ~;~]finalized. ~
150     The class precedence list is:~%~S~%~
151 ram 1.6 There are ~D methods specialized for this class."
152     (mapcar #'pretty-class (class-direct-superclasses class))
153     (mapcar #'pretty-class (class-direct-subclasses class))
154 gerd 1.25 (class-finalized-p class)
155     (mapcar #'pretty-class (cpl-or-nil class))
156 gerd 1.17 (length (specializer-direct-methods class)))
157 gerd 1.19 (unless (typep class 'condition-class)
158 rtoy 1.26.48.2 (loop initially (ft _"~&Its direct slots are:~%")
159 gerd 1.19 for slotd in (class-direct-slots class)
160     as name = (slot-definition-name slotd)
161     as doc = (slot-value slotd 'documentation) do
162 rtoy 1.26.48.2 (ft _" ~a, documentation ~s~%" name doc)))))
163 ram 1.6 (when *describe-metaobjects-as-objects-p*
164     (call-next-method)))
165 wlott 1.1
166 ram 1.6 (defun describe-package (object stream)
167     (unless (packagep object) (setq object (find-package object)))
168 rtoy 1.26.48.2 (format stream _"~&~S is a ~S.~%" object (type-of object))
169 ram 1.6 (let ((nick (package-nicknames object)))
170     (when nick
171 rtoy 1.26.48.2 (format stream _"You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
172 ram 1.6 (butlast nick) (first (last nick)))))
173 pw 1.12 (let* ((internal (lisp::package-internal-symbols object))
174     (internal-count (- (lisp::package-hashtable-size internal)
175     (lisp::package-hashtable-free internal)))
176     (external (lisp::package-external-symbols object))
177     (external-count (- (lisp::package-hashtable-size external)
178     (lisp::package-hashtable-free external))))
179 rtoy 1.26.48.2 (format stream _"It has ~D internal and ~D external symbols (~D total).~%"
180 ram 1.6 internal-count external-count (+ internal-count external-count)))
181     (let ((used (package-use-list object)))
182     (when used
183 rtoy 1.26.48.2 (format stream _"It uses the packages ~{~S~^, ~}.~%"
184 ram 1.6 (mapcar #'package-name used))))
185 pw 1.9 (let ((users (package-used-by-list object)))
186 ram 1.6 (when users
187 rtoy 1.26.48.2 (format stream _"It is used by the packages ~{~S~^, ~}.~%"
188 ram 1.6 (mapcar #'package-name users)))))
189 wlott 1.1
190 ram 1.6 (defmethod describe-object ((object package) stream)
191     (describe-package object stream))
192 ram 1.5
193 ram 1.6 (defmethod describe-object ((object hash-table) stream)
194 rtoy 1.26.48.2 (format stream _"~&~S is an ~a hash table."
195 phg 1.7 object
196 pw 1.12 (lisp::hash-table-test object))
197 rtoy 1.26.48.2 (format stream _"~&Its size is ~d buckets."
198 phg 1.7 (lisp::hash-table-size object))
199 rtoy 1.26.48.2 (format stream _"~&Its rehash-size is ~d."
200 phg 1.7 (lisp::hash-table-rehash-size object))
201 rtoy 1.26.48.2 (format stream _"~&Its rehash-threshold is ~d."
202 pw 1.8 (hash-table-rehash-threshold object))
203 rtoy 1.26.48.2 (format stream _"~&It currently holds ~d entries."
204 ram 1.6 (lisp::hash-table-number-entries object)))
205 ram 1.5
206 ram 1.6
207    
208 wlott 1.1 ;;;
209 gerd 1.19 ;;; Value is a list of all (possible) method function names of
210     ;;; generic function GF.
211     ;;;
212     (defun debug::all-method-function-names (gf)
213     (loop with gf = (if (symbolp gf) (gdefinition gf) gf)
214     for method in (generic-function-methods gf)
215     as name = (nth-value 2 (parse-method-or-spec method))
216     collect name
217     collect (list* 'fast-method (cdr name))))
218    
219     (defun debug::all-method-functions-in-package (pkg)
220     (let ((gfs ()))
221     (map-all-generic-functions
222     (lambda (gf)
223     (multiple-value-bind (valid base)
224 gerd 1.21 (valid-function-name-p (generic-function-name gf))
225 gerd 1.19 (declare (ignore valid))
226     (when (and (symbolp base)
227     (eq (symbol-package base) pkg))
228     (push gf gfs)))))
229     (loop for gf in gfs nconc (debug::all-method-function-names gf))))
230    
231     ;;;
232     ;;; Reinitialize method function NAME from its fdefinitions.
233     ;;;
234     (defun profile::reinitialize-method-function (name)
235     (multiple-value-bind (gf method method-name)
236     (parse-method-or-spec (cdr name))
237     (declare (ignore gf method-name))
238     (with-slots (function fast-function) method
239     (ecase (car name)
240     (method
241     (when function
242     (setq function (fdefinition name))))
243     (fast-method
244     (when fast-function
245     (let* ((new (fdefinition name))
246     (plist (method-function-plist new)))
247     ;;
248     ;; This is necessary so that, for instance, the arg-info of
249     ;; the function can be determined.
250     (unless plist
251     (setf (method-function-plist new)
252     (method-function-plist fast-function)))
253     (setq fast-function new))))))))
254 wlott 1.1
255     (defmacro undefmethod (&rest args)
256     `(undefmethod-1 ',args))
257    
258     (defun undefmethod-1 (args)
259     (multiple-value-bind (gf method)
260     (parse-method-or-spec args)
261     (when (and gf method)
262     (remove-method gf method)
263     method)))
264    
265 ram 1.4
266     (pushnew :pcl *features*)
267     (pushnew :portable-commonloops *features*)
268     (pushnew :pcl-structures *features*)
269 gerd 1.19 (pushnew :gerds-pcl *features*)
270 pw 1.8
271     (when (find-package "OLD-PCL")
272     (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
273     (symbol-function 'pcl::print-object)))
274    
275    
276     ;;;; MAKE-LOAD-FORM
277    
278 gerd 1.26 (export '(lisp::make-load-form lisp::make-load-form-saving-slots) "CL")
279 pw 1.8
280 pw 1.12 (defgeneric make-load-form (object &optional environment))
281 gerd 1.22
282     (macrolet ((define-default-method (class)
283     `(defmethod make-load-form ((object ,class) &optional env)
284     (declare (ignore env))
285 rtoy 1.26.48.2 (error _"~@<Default ~s method for ~s called.~@>"
286 gerd 1.22 'make-load-form object))))
287     (define-default-method condition)
288     (define-default-method standard-object))
289 pw 1.12
290     (defmethod make-load-form ((object structure-object) &optional environment)
291     (declare (ignore environment))
292     (kernel:make-structure-load-form object))
293    
294     (defmethod make-load-form ((object wrapper) &optional env)
295     (declare (ignore env))
296     (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
297     (unless pname
298 rtoy 1.26.48.2 (error _"~@<Can't dump wrapper for anonymous class ~S.~@:>"
299 pw 1.12 (kernel:layout-class object)))
300 gerd 1.19 `(kernel:%class-layout (kernel::find-class ',pname))))
301 pw 1.12
302 gerd 1.19 (defmethod make-load-form ((class class) &optional env)
303     (declare (ignore env))
304     (let ((name (class-name class)))
305     (unless (and name (eq (find-class name nil) class))
306 rtoy 1.26.48.2 (error _"~@<Can't use anonymous or undefined class as constant: ~S~:@>"
307 gerd 1.19 class))
308     `(find-class ',name)))
309 gerd 1.23
310 pw 1.12 (defun make-load-form-saving-slots (object &key slot-names environment)
311     (declare (ignore environment))
312 gerd 1.23 (let ((class (class-of object)))
313     (collect ((inits))
314     (dolist (slot (class-slots class))
315     (let ((slot-name (slot-definition-name slot)))
316     (when (or (memq slot-name slot-names)
317     (and (null slot-names)
318     (eq :instance (slot-definition-allocation slot))))
319     (if (slot-boundp-using-class class object slot)
320     (let ((value (slot-value-using-class class object slot)))
321     (inits `(setf (slot-value ,object ',slot-name) ',value)))
322     (inits `(slot-makunbound ,object ',slot-name))))))
323     (values `(allocate-instance (find-class ',(class-name class)))
324     `(progn .,(inits))))))
325 pw 1.8

  ViewVC Help
Powered by ViewVC 1.1.5