share/guile/1.6.0/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   :export (describe))                   ; Export the describe generic function
  58
  59 ;;;
  60 ;;; describe for simple objects
  61 ;;;
  62 (define-method (describe (x <top>))
  63   (format #t "~s is " x)
  64   (cond
  65      ((integer? x)      (format #t "an integer"))
  66      ((real?    x)      (format #t "a real"))
  67      ((complex? x)      (format #t "a complex number"))
  68      ((null?    x)      (format #t "an empty list"))
  69      ((boolean? x)      (format #t "a boolean value (~s)" (if x 'true 'false)))
  70      ((char?    x)      (format #t "a character, ascii value is ~s"
  71                                 (char->integer x)))
  72      ((symbol?  x)      (format #t "a symbol"))
  73      ((list?    x)      (format #t "a list"))
  74      ((pair?    x)      (if (pair? (cdr x))
  75                             (format #t "an improper list")
  76                             (format #t "a pair")))
  77      ((string?  x)      (if (eqv? x "")
  78                             (format #t "an empty string")
  79                             (format #t "a string of length ~s" (string-length x))))
  80      ((vector?  x)      (if (eqv? x '#())
  81                             (format #t "an empty vector")
  82                             (format #t "a vector of length ~s" (vector-length x))))
  83      ((eof-object? x)   (format #t "the end-of-file object"))
  84      (else              (format #t "an unknown object (~s)" x)))
  85   (format #t ".~%")
  86   *unspecified*)
  87
  88 (define-method (describe (x <procedure>))
  89   (let ((name (procedure-name x)))
  90     (if name
  91         (format #t "`~s'" name)
  92         (display x))
  93     (display " is ")
  94     (display (if name #\a "an anonymous"))
  95     (display (cond ((closure? x) " procedure")
  96                    ((not (struct? x)) " primitive procedure")
  97                    ((entity? x) " entity")
  98                    (else " operator")))
  99     (display " with ")
 100     (arity x)))
 101
 102 ;;;
 103 ;;; describe for GOOPS instances
 104 ;;;
 105 (define (safe-class-name class)
 106   (if (slot-bound? class 'name)
 107       (class-name class)
 108       class))
 109
 110 (define-method (describe (x <object>))
 111   (format #t "~S is an instance of class ~A~%"
 112           x (safe-class-name (class-of x)))
 113
 114   ;; print all the instance slots
 115   (format #t "Slots are: ~%")
 116   (for-each (lambda (slot)
 117               (let ((name (slot-definition-name slot)))
 118                 (format #t "     ~S = ~A~%"
 119                         name
 120                         (if (slot-bound? x name)
 121                             (format #f "~S" (slot-ref x name))
 122                             "#<unbound>"))))
 123             (class-slots (class-of x)))
 124   *unspecified*)
 125
 126 ;;;
 127 ;;; Describe for classes
 128 ;;;
 129 (define-method (describe (x <class>))
 130   (format #t "~S is a class. It's an instance of ~A~%"
 131           (safe-class-name x) (safe-class-name (class-of x)))
 132
 133   ;; Super classes
 134   (format #t "Superclasses are:~%")
 135   (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
 136        (class-direct-supers x))
 137
 138   ;; Direct slots
 139   (let ((slots (class-direct-slots x)))
 140     (if (null? slots)
 141         (format #t "(No direct slot)~%")
 142         (begin
 143           (format #t "Directs slots are:~%")
 144           (for-each (lambda (s)
 145                       (format #t "    ~A~%" (slot-definition-name s)))
 146                     slots))))
 147
 148
 149   ;; Direct subclasses
 150   (let ((classes (class-direct-subclasses x)))
 151     (if (null? classes)
 152         (format #t "(No direct subclass)~%")
 153         (begin
 154           (format #t "Directs subclasses are:~%")
 155           (for-each (lambda (s)
 156                       (format #t "    ~A~%" (safe-class-name s)))
 157                     classes))))
 158
 159   ;; CPL
 160   (format #t "Class Precedence List is:~%")
 161   (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s)))
 162             (class-precedence-list x))
 163
 164   ;; Direct Methods
 165   (let ((methods (class-direct-methods x)))
 166     (if (null? methods)
 167         (format #t "(No direct method)~%")
 168         (begin
 169           (format #t "Class direct methods are:~%")
 170           (for-each describe methods))))
 171
 172 ;  (format #t "~%Field Initializers ~%    ")
 173 ;  (write (slot-ref x 'initializers)) (newline)
 174
 175 ;  (format #t "~%Getters and Setters~%    ")
 176 ;  (write (slot-ref x 'getters-n-setters)) (newline)
 177 )
 178
 179 ;;;
 180 ;;; Describe for generic functions
 181 ;;;
 182 (define-method (describe (x <generic>))
 183   (let ((name    (generic-function-name x))
 184         (methods (generic-function-methods x)))
 185     ;; Title
 186     (format #t "~S is a generic function. It's an instance of ~A.~%"
 187             name (safe-class-name (class-of x)))
 188     ;; Methods
 189     (if (null? methods)
 190         (format #t "(No method defined for ~S)~%" name)
 191         (begin
 192           (format #t "Methods defined for ~S~%" name)
 193           (for-each (lambda (x) (describe x #t)) methods)))))
 194
 195 ;;;
 196 ;;; Describe for methods
 197 ;;;
 198 (define-method (describe (x <method>) . omit-generic)
 199   (letrec ((print-args (lambda (args)
 200                          ;; take care of dotted arg lists
 201                          (cond ((null? args) (newline))
 202                                ((pair? args)
 203                                 (display #\space)
 204                                 (display (safe-class-name (car args)))
 205                                 (print-args (cdr args)))
 206                                (else
 207                                 (display #\space)
 208                                 (display (safe-class-name args))
 209                                 (newline))))))
 210
 211     ;; Title
 212     (format #t "    Method ~A~%" x)
 213
 214     ;; Associated generic
 215     (if (null? omit-generic)
 216       (let ((gf (method-generic-function x)))
 217         (if gf
 218             (format #t "\t     Generic: ~A~%" (generic-function-name gf))
 219             (format #t "\t(No generic)~%"))))
 220
 221     ;; GF specializers
 222     (format #t "\tSpecializers:")
 223     (print-args (method-specializers x))))
 224
 225 (provide "describe")