module/oop/goops/describe.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
   4 ;;;;
   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 3 of the License, or (at your option) any later version.
   9 ;;;;
  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.
  14 ;;;;
  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
  18 ;;;;
  19 \f
  20
  21 ;;;; This software is a derivative work of other copyrighted softwares; the
  22 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  23 ;;;;
  24 ;;;; This file is based upon describe.stklos from the STk distribution by
  25 ;;;; Erick Gallesio <eg@unice.fr>.
  26 ;;;;
  27
  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
  33
  34 ;;;
  35 ;;; describe for simple objects
  36 ;;;
  37 (define-method (describe (x <top>))
  38   (format #t "~s is " x)
  39   (cond
  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"
  46                                 (char->integer x)))
  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)))
  60   (format #t ".~%")
  61   *unspecified*)
  62
  63 (define-method (describe (x <procedure>))
  64   (let ((name (procedure-name x)))
  65     (if name
  66         (format #t "`~s'" name)
  67         (display x))
  68     (display " is ")
  69     (display (if name #\a "an anonymous"))
  70     (display " procedure")
  71     (display " with ")
  72     (arity x)))
  73
  74 ;;;
  75 ;;; describe for GOOPS instances
  76 ;;;
  77 (define (safe-class-name class)
  78   (if (slot-bound? class 'name)
  79       (class-name class)
  80       class))
  81
  82 (define-method (describe (x <object>))
  83   (format #t "~S is an instance of class ~A~%"
  84           x (safe-class-name (class-of x)))
  85
  86   ;; print all the instance slots
  87   (format #t "Slots are: ~%")
  88   (for-each (lambda (slot)
  89               (let ((name (slot-definition-name slot)))
  90                 (format #t "     ~S = ~A~%"
  91                         name
  92                         (if (slot-bound? x name)
  93                             (format #f "~S" (slot-ref x name))
  94                             "#<unbound>"))))
  95             (class-slots (class-of x)))
  96   *unspecified*)
  97
  98 ;;;
  99 ;;; Describe for classes
 100 ;;;
 101 (define-method (describe (x <class>))
 102   (format #t "~S is a class. It's an instance of ~A~%"
 103           (safe-class-name x) (safe-class-name (class-of x)))
 104
 105   ;; Super classes
 106   (format #t "Superclasses are:~%")
 107   (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
 108        (class-direct-supers x))
 109
 110   ;; Direct slots
 111   (let ((slots (class-direct-slots x)))
 112     (if (null? slots)
 113         (format #t "(No direct slot)~%")
 114         (begin
 115           (format #t "Directs slots are:~%")
 116           (for-each (lambda (s)
 117                       (format #t "    ~A~%" (slot-definition-name s)))
 118                     slots))))
 119
 120
 121   ;; Direct subclasses
 122   (let ((classes (class-direct-subclasses x)))
 123     (if (null? classes)
 124         (format #t "(No direct subclass)~%")
 125         (begin
 126           (format #t "Directs subclasses are:~%")
 127           (for-each (lambda (s)
 128                       (format #t "    ~A~%" (safe-class-name s)))
 129                     classes))))
 130
 131   ;; CPL
 132   (format #t "Class Precedence List is:~%")
 133   (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s)))
 134             (class-precedence-list x))
 135
 136   ;; Direct Methods
 137   (let ((methods (class-direct-methods x)))
 138     (if (null? methods)
 139         (format #t "(No direct method)~%")
 140         (begin
 141           (format #t "Class direct methods are:~%")
 142           (for-each describe methods))))
 143
 144 ;  (format #t "~%Field Initializers ~%    ")
 145 ;  (write (slot-ref x 'initializers)) (newline)
 146
 147 ;  (format #t "~%Getters and Setters~%    ")
 148 ;  (write (slot-ref x 'getters-n-setters)) (newline)
 149 )
 150
 151 ;;;
 152 ;;; Describe for generic functions
 153 ;;;
 154 (define-method (describe (x <generic>))
 155   (let ((name    (generic-function-name x))
 156         (methods (generic-function-methods x)))
 157     ;; Title
 158     (format #t "~S is a generic function. It's an instance of ~A.~%"
 159             name (safe-class-name (class-of x)))
 160     ;; Methods
 161     (if (null? methods)
 162         (format #t "(No method defined for ~S)~%" name)
 163         (begin
 164           (format #t "Methods defined for ~S~%" name)
 165           (for-each (lambda (x) (describe x #t)) methods)))))
 166
 167 ;;;
 168 ;;; Describe for methods
 169 ;;;
 170 (define-method (describe (x <method>) . omit-generic)
 171   (letrec ((print-args (lambda (args)
 172                          ;; take care of dotted arg lists
 173                          (cond ((null? args) (newline))
 174                                ((pair? args)
 175                                 (display #\space)
 176                                 (display (safe-class-name (car args)))
 177                                 (print-args (cdr args)))
 178                                (else
 179                                 (display #\space)
 180                                 (display (safe-class-name args))
 181                                 (newline))))))
 182
 183     ;; Title
 184     (format #t "    Method ~A~%" x)
 185
 186     ;; Associated generic
 187     (if (null? omit-generic)
 188       (let ((gf (method-generic-function x)))
 189         (if gf
 190             (format #t "\t     Generic: ~A~%" (generic-function-name gf))
 191             (format #t "\t(No generic)~%"))))
 192
 193     ;; GF specializers
 194     (format #t "\tSpecializers:")
 195     (print-args (method-specializers x))))
 196
 197 (provide 'describe)