3
;;;; Copyright (C) 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
5
;;;; This library is free software; you can redistribute it and/or
6
;;;; modify it under the terms of the GNU Lesser General Public
7
;;;; License as published by the Free Software Foundation; either
8
;;;; version 2.1 of the License, or (at your option) any later version.
10
;;;; This library is distributed in the hope that it will be useful,
11
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13
;;;; Lesser General Public License for more details.
15
;;;; You should have received a copy of the GNU Lesser General Public
16
;;;; License along with this library; if not, write to the Free Software
17
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
;;;; This software is a derivative work of other copyrighted softwares; the
22
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
24
;;;; This file is based upon describe.stklos from the STk distribution by
25
;;;; Erick Gallesio <eg@unice.fr>.
28
(define-module (oop goops describe)
29
:use-module (oop goops)
30
:use-module (ice-9 session)
31
:use-module (ice-9 format)
32
:export (describe)) ; Export the describe generic function
35
;;; describe for simple objects
37
(define-method (describe (x <top>))
38
(format #t "~s is " x)
40
((integer? x) (format #t "an integer"))
41
((real? x) (format #t "a real"))
42
((complex? x) (format #t "a complex number"))
43
((null? x) (format #t "an empty list"))
44
((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false)))
45
((char? x) (format #t "a character, ascii value is ~s"
47
((symbol? x) (format #t "a symbol"))
48
((list? x) (format #t "a list"))
49
((pair? x) (if (pair? (cdr x))
50
(format #t "an improper list")
51
(format #t "a pair")))
52
((string? x) (if (eqv? x "")
53
(format #t "an empty string")
54
(format #t "a string of length ~s" (string-length x))))
55
((vector? x) (if (eqv? x '#())
56
(format #t "an empty vector")
57
(format #t "a vector of length ~s" (vector-length x))))
58
((eof-object? x) (format #t "the end-of-file object"))
59
(else (format #t "an unknown object (~s)" x)))
63
(define-method (describe (x <procedure>))
64
(let ((name (procedure-name x)))
66
(format #t "`~s'" name)
69
(display (if name #\a "an anonymous"))
70
(display (cond ((closure? x) " procedure")
71
((not (struct? x)) " primitive procedure")
72
((entity? x) " entity")
78
;;; describe for GOOPS instances
80
(define (safe-class-name class)
81
(if (slot-bound? class 'name)
85
(define-method (describe (x <object>))
86
(format #t "~S is an instance of class ~A~%"
87
x (safe-class-name (class-of x)))
89
;; print all the instance slots
90
(format #t "Slots are: ~%")
91
(for-each (lambda (slot)
92
(let ((name (slot-definition-name slot)))
93
(format #t " ~S = ~A~%"
95
(if (slot-bound? x name)
96
(format #f "~S" (slot-ref x name))
98
(class-slots (class-of x)))
102
;;; Describe for classes
104
(define-method (describe (x <class>))
105
(format #t "~S is a class. It's an instance of ~A~%"
106
(safe-class-name x) (safe-class-name (class-of x)))
109
(format #t "Superclasses are:~%")
110
(for-each (lambda (class) (format #t " ~A~%" (safe-class-name class)))
111
(class-direct-supers x))
114
(let ((slots (class-direct-slots x)))
116
(format #t "(No direct slot)~%")
118
(format #t "Directs slots are:~%")
119
(for-each (lambda (s)
120
(format #t " ~A~%" (slot-definition-name s)))
125
(let ((classes (class-direct-subclasses x)))
127
(format #t "(No direct subclass)~%")
129
(format #t "Directs subclasses are:~%")
130
(for-each (lambda (s)
131
(format #t " ~A~%" (safe-class-name s)))
135
(format #t "Class Precedence List is:~%")
136
(for-each (lambda (s) (format #t " ~A~%" (safe-class-name s)))
137
(class-precedence-list x))
140
(let ((methods (class-direct-methods x)))
142
(format #t "(No direct method)~%")
144
(format #t "Class direct methods are:~%")
145
(for-each describe methods))))
147
; (format #t "~%Field Initializers ~% ")
148
; (write (slot-ref x 'initializers)) (newline)
150
; (format #t "~%Getters and Setters~% ")
151
; (write (slot-ref x 'getters-n-setters)) (newline)
155
;;; Describe for generic functions
157
(define-method (describe (x <generic>))
158
(let ((name (generic-function-name x))
159
(methods (generic-function-methods x)))
161
(format #t "~S is a generic function. It's an instance of ~A.~%"
162
name (safe-class-name (class-of x)))
165
(format #t "(No method defined for ~S)~%" name)
167
(format #t "Methods defined for ~S~%" name)
168
(for-each (lambda (x) (describe x #t)) methods)))))
171
;;; Describe for methods
173
(define-method (describe (x <method>) . omit-generic)
174
(letrec ((print-args (lambda (args)
175
;; take care of dotted arg lists
176
(cond ((null? args) (newline))
179
(display (safe-class-name (car args)))
180
(print-args (cdr args)))
183
(display (safe-class-name args))
187
(format #t " Method ~A~%" x)
189
;; Associated generic
190
(if (null? omit-generic)
191
(let ((gf (method-generic-function x)))
193
(format #t "\t Generic: ~A~%" (generic-function-name gf))
194
(format #t "\t(No generic)~%"))))
197
(format #t "\tSpecializers:")
198
(print-args (method-specializers x))))
added
removed
oop/goops/describe.scm
