oop/goops/describe.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1998, 1999 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 \f
  21
  22 ;;;; This software is a derivative work of other copyrighted softwares; the
  23 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  24 ;;;;
  25 ;;;; This file is based upon describe.stklos from the STk distribution by
  26 ;;;; Erick Gallesio <eg@unice.fr>.
  27 ;;;;
  28
  29 (define-module (oop goops describe)
  30   :use-module (oop goops)
  31   :use-module (ice-9 session)
  32   :use-module (ice-9 format))
  33
  34 (export describe)                       ; Export the describe generic function
  35
  36 ;;;
  37 ;;; describe for simple objects
  38 ;;;
  39 (define-method describe ((x <top>))
  40   (format #t "~s is " x)
  41   (cond
  42      ((integer? x)      (format #t "an integer"))
  43      ((real?    x)      (format #t "a real"))
  44      ((complex? x)      (format #t "a complex number"))
  45      ((null?    x)      (format #t "an empty list"))
  46      ((boolean? x)      (format #t "a boolean value (~s)" (if x 'true 'false)))
  47      ((char?    x)      (format #t "a character, ascii value is ~s"
  48                                 (char->integer x)))
  49      ((symbol?  x)      (format #t "a symbol"))
  50      ((list?    x)      (format #t "a list"))
  51      ((pair?    x)      (if (pair? (cdr x))
  52                             (format #t "an improper list")
  53                             (format #t "a pair")))
  54      ((string?  x)      (if (eqv? x "")
  55                             (format #t "an empty string")
  56                             (format #t "a string of length ~s" (string-length x))))
  57      ((vector?  x)      (if (eqv? x '#())
  58                             (format #t "an empty vector")
  59                             (format #t "a vector of length ~s" (vector-length x))))
  60      ((eof-object? x)   (format #t "the end-of-file object"))
  61      (else              (format #t "an unknown object (~s)" x)))
  62   (format #t ".~%")
  63   *unspecified*)
  64
  65 (define-method describe ((x <procedure>))
  66   (let ((name (procedure-name x)))
  67     (if name
  68         (format #t "`~s'" name)
  69         (display x))
  70     (display " is ")
  71     (display (if name #\a "an anonymous"))
  72     (display (cond ((closure? x) " procedure")
  73                    ((not (struct? x)) " primitive procedure")
  74                    ((entity? x) " entity")
  75                    (else " operator")))
  76     (display " with ")
  77     (arity x)))
  78
  79 ;;;
  80 ;;; describe for GOOPS instances
  81 ;;;
  82 (define (safe-class-name class)
  83   (if (slot-bound? class 'name)
  84       (class-name class)
  85       class))
  86
  87 (define-method describe ((x <object>))
  88   (format #t "~S is an instance of class ~A~%"
  89           x (safe-class-name (class-of x)))
  90
  91   ;; print all the instance slots
  92   (format #t "Slots are: ~%")
  93   (for-each (lambda (slot)
  94               (let ((name (slot-definition-name slot)))
  95                 (format #t "     ~S = ~A~%"
  96                         name
  97                         (if (slot-bound? x name)
  98                             (format #f "~S" (slot-ref x name))
  99                             "#<unbound>"))))
 100             (class-slots (class-of x)))
 101   *unspecified*)
 102
 103 ;;;
 104 ;;; Describe for classes
 105 ;;;
 106 (define-method describe ((x <class>))
 107   (format #t "~S is a class. It's an instance of ~A~%"
 108           (safe-class-name x) (safe-class-name (class-of x)))
 109
 110   ;; Super classes
 111   (format #t "Superclasses are:~%")
 112   (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
 113        (class-direct-supers x))
 114
 115   ;; Direct slots
 116   (let ((slots (class-direct-slots x)))
 117     (if (null? slots)
 118         (format #t "(No direct slot)~%")
 119         (begin
 120           (format #t "Directs slots are:~%")
 121           (for-each (lambda (s)
 122                       (format #t "    ~A~%" (slot-definition-name s)))
 123                     slots))))
 124
 125
 126   ;; Direct subclasses
 127   (let ((classes (class-direct-subclasses x)))
 128     (if (null? classes)
 129         (format #t "(No direct subclass)~%")
 130         (begin
 131           (format #t "Directs subclasses are:~%")
 132           (for-each (lambda (s)
 133                       (format #t "    ~A~%" (safe-class-name s)))
 134                     classes))))
 135
 136   ;; CPL
 137   (format #t "Class Precedence List is:~%")
 138   (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s)))
 139             (class-precedence-list x))
 140
 141   ;; Direct Methods
 142   (let ((methods (class-direct-methods x)))
 143     (if (null? methods)
 144         (format #t "(No direct method)~%")
 145         (begin
 146           (format #t "Class direct methods are:~%")
 147           (for-each describe methods))))
 148
 149 ;  (format #t "~%Field Initializers ~%    ")
 150 ;  (write (slot-ref x 'initializers)) (newline)
 151
 152 ;  (format #t "~%Getters and Setters~%    ")
 153 ;  (write (slot-ref x 'getters-n-setters)) (newline)
 154 )
 155
 156 ;;;
 157 ;;; Describe for generic functions
 158 ;;;
 159 (define-method describe ((x <generic>))
 160   (let ((name    (generic-function-name x))
 161         (methods (generic-function-methods x)))
 162     ;; Title
 163     (format #t "~S is a generic function. It's an instance of ~A.~%"
 164             name (safe-class-name (class-of x)))
 165     ;; Methods
 166     (if (null? methods)
 167         (format #t "(No method defined for ~S)~%" name)
 168         (begin
 169           (format #t "Methods defined for ~S~%" name)
 170           (for-each (lambda (x) (describe x #t)) methods)))))
 171
 172 ;;;
 173 ;;; Describe for methods
 174 ;;;
 175 (define-method describe ((x <method>) . omit-generic)
 176   (letrec ((print-args (lambda (args)
 177                          ;; take care of dotted arg lists
 178                          (cond ((null? args) (newline))
 179                                ((pair? args)
 180                                 (display #\space)
 181                                 (display (safe-class-name (car args)))
 182                                 (print-args (cdr args)))
 183                                (else
 184                                 (display #\space)
 185                                 (display (safe-class-name args))
 186                                 (newline))))))
 187
 188     ;; Title
 189     (format #t "    Method ~A~%" x)
 190
 191     ;; Associated generic
 192     (if (null? omit-generic)
 193       (let ((gf (method-generic-function x)))
 194         (if gf
 195             (format #t "\t     Generic: ~A~%" (generic-function-name gf))
 196             (format #t "\t(No generic)~%"))))
 197
 198     ;; GF specializers
 199     (format #t "\tSpecializers:")
 200     (print-args (method-specializers x))))
 201
 202 (provide "describe")