oop/goops/describe.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program 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
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43 ;;;;
  44 \f
  45
  46 ;;;; This software is a derivative work of other copyrighted softwares; the
  47 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  48 ;;;;
  49 ;;;; This file is based upon describe.stklos from the STk distribution by
  50 ;;;; Erick Gallesio <eg@unice.fr>.
  51 ;;;;
  52
  53 (define-module (oop goops describe)
  54   :use-module (oop goops)
  55   :use-module (ice-9 session)
  56   :use-module (ice-9 format))
  57
  58 (export describe)                       ; Export the describe generic function
  59
  60 ;;;
  61 ;;; describe for simple objects
  62 ;;;
  63 (define-method (describe (x <top>))
  64   (format #t "~s is " x)
  65   (cond
  66      ((integer? x)      (format #t "an integer"))
  67      ((real?    x)      (format #t "a real"))
  68      ((complex? x)      (format #t "a complex number"))
  69      ((null?    x)      (format #t "an empty list"))
  70      ((boolean? x)      (format #t "a boolean value (~s)" (if x 'true 'false)))
  71      ((char?    x)      (format #t "a character, ascii value is ~s"
  72                                 (char->integer x)))
  73      ((symbol?  x)      (format #t "a symbol"))
  74      ((list?    x)      (format #t "a list"))
  75      ((pair?    x)      (if (pair? (cdr x))
  76                             (format #t "an improper list")
  77                             (format #t "a pair")))
  78      ((string?  x)      (if (eqv? x "")
  79                             (format #t "an empty string")
  80                             (format #t "a string of length ~s" (string-length x))))
  81      ((vector?  x)      (if (eqv? x '#())
  82                             (format #t "an empty vector")
  83                             (format #t "a vector of length ~s" (vector-length x))))
  84      ((eof-object? x)   (format #t "the end-of-file object"))
  85      (else              (format #t "an unknown object (~s)" x)))
  86   (format #t ".~%")
  87   *unspecified*)
  88
  89 (define-method (describe (x <procedure>))
  90   (let ((name (procedure-name x)))
  91     (if name
  92         (format #t "`~s'" name)
  93         (display x))
  94     (display " is ")
  95     (display (if name #\a "an anonymous"))
  96     (display (cond ((closure? x) " procedure")
  97                    ((not (struct? x)) " primitive procedure")
  98                    ((entity? x) " entity")
  99                    (else " operator")))
 100     (display " with ")
 101     (arity x)))
 102
 103 ;;;
 104 ;;; describe for GOOPS instances
 105 ;;;
 106 (define (safe-class-name class)
 107   (if (slot-bound? class 'name)
 108       (class-name class)
 109       class))
 110
 111 (define-method (describe (x <object>))
 112   (format #t "~S is an instance of class ~A~%"
 113           x (safe-class-name (class-of x)))
 114
 115   ;; print all the instance slots
 116   (format #t "Slots are: ~%")
 117   (for-each (lambda (slot)
 118               (let ((name (slot-definition-name slot)))
 119                 (format #t "     ~S = ~A~%"
 120                         name
 121                         (if (slot-bound? x name)
 122                             (format #f "~S" (slot-ref x name))
 123                             "#<unbound>"))))
 124             (class-slots (class-of x)))
 125   *unspecified*)
 126
 127 ;;;
 128 ;;; Describe for classes
 129 ;;;
 130 (define-method (describe (x <class>))
 131   (format #t "~S is a class. It's an instance of ~A~%"
 132           (safe-class-name x) (safe-class-name (class-of x)))
 133
 134   ;; Super classes
 135   (format #t "Superclasses are:~%")
 136   (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
 137        (class-direct-supers x))
 138
 139   ;; Direct slots
 140   (let ((slots (class-direct-slots x)))
 141     (if (null? slots)
 142         (format #t "(No direct slot)~%")
 143         (begin
 144           (format #t "Directs slots are:~%")
 145           (for-each (lambda (s)
 146                       (format #t "    ~A~%" (slot-definition-name s)))
 147                     slots))))
 148
 149
 150   ;; Direct subclasses
 151   (let ((classes (class-direct-subclasses x)))
 152     (if (null? classes)
 153         (format #t "(No direct subclass)~%")
 154         (begin
 155           (format #t "Directs subclasses are:~%")
 156           (for-each (lambda (s)
 157                       (format #t "    ~A~%" (safe-class-name s)))
 158                     classes))))
 159
 160   ;; CPL
 161   (format #t "Class Precedence List is:~%")
 162   (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s)))
 163             (class-precedence-list x))
 164
 165   ;; Direct Methods
 166   (let ((methods (class-direct-methods x)))
 167     (if (null? methods)
 168         (format #t "(No direct method)~%")
 169         (begin
 170           (format #t "Class direct methods are:~%")
 171           (for-each describe methods))))
 172
 173 ;  (format #t "~%Field Initializers ~%    ")
 174 ;  (write (slot-ref x 'initializers)) (newline)
 175
 176 ;  (format #t "~%Getters and Setters~%    ")
 177 ;  (write (slot-ref x 'getters-n-setters)) (newline)
 178 )
 179
 180 ;;;
 181 ;;; Describe for generic functions
 182 ;;;
 183 (define-method (describe (x <generic>))
 184   (let ((name    (generic-function-name x))
 185         (methods (generic-function-methods x)))
 186     ;; Title
 187     (format #t "~S is a generic function. It's an instance of ~A.~%"
 188             name (safe-class-name (class-of x)))
 189     ;; Methods
 190     (if (null? methods)
 191         (format #t "(No method defined for ~S)~%" name)
 192         (begin
 193           (format #t "Methods defined for ~S~%" name)
 194           (for-each (lambda (x) (describe x #t)) methods)))))
 195
 196 ;;;
 197 ;;; Describe for methods
 198 ;;;
 199 (define-method (describe (x <method>) . omit-generic)
 200   (letrec ((print-args (lambda (args)
 201                          ;; take care of dotted arg lists
 202                          (cond ((null? args) (newline))
 203                                ((pair? args)
 204                                 (display #\space)
 205                                 (display (safe-class-name (car args)))
 206                                 (print-args (cdr args)))
 207                                (else
 208                                 (display #\space)
 209                                 (display (safe-class-name args))
 210                                 (newline))))))
 211
 212     ;; Title
 213     (format #t "    Method ~A~%" x)
 214
 215     ;; Associated generic
 216     (if (null? omit-generic)
 217       (let ((gf (method-generic-function x)))
 218         (if gf
 219             (format #t "\t     Generic: ~A~%" (generic-function-name gf))
 220             (format #t "\t(No generic)~%"))))
 221
 222     ;; GF specializers
 223     (format #t "\tSpecializers:")
 224     (print-args (method-specializers x))))
 225
 226 (provide "describe")