guile18/oop/goops/describe.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1998, 1999, 2001, 2006, 2008 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 2.1 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 (cond ((closure? x) " procedure")
  71                    ((not (struct? x)) " primitive procedure")
  72                    ((entity? x) " entity")
  73                    (else " operator")))
  74     (display " with ")
  75     (arity x)))
  76
  77 ;;;
  78 ;;; describe for GOOPS instances
  79 ;;;
  80 (define (safe-class-name class)
  81   (if (slot-bound? class 'name)
  82       (class-name class)
  83       class))
  84
  85 (define-method (describe (x <object>))
  86   (format #t "~S is an instance of class ~A~%"
  87           x (safe-class-name (class-of x)))
  88
  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~%"
  94                         name
  95                         (if (slot-bound? x name)
  96                             (format #f "~S" (slot-ref x name))
  97                             "#<unbound>"))))
  98             (class-slots (class-of x)))
  99   *unspecified*)
 100
 101 ;;;
 102 ;;; Describe for classes
 103 ;;;
 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)))
 107
 108   ;; Super classes
 109   (format #t "Superclasses are:~%")
 110   (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
 111        (class-direct-supers x))
 112
 113   ;; Direct slots
 114   (let ((slots (class-direct-slots x)))
 115     (if (null? slots)
 116         (format #t "(No direct slot)~%")
 117         (begin
 118           (format #t "Directs slots are:~%")
 119           (for-each (lambda (s)
 120                       (format #t "    ~A~%" (slot-definition-name s)))
 121                     slots))))
 122
 123
 124   ;; Direct subclasses
 125   (let ((classes (class-direct-subclasses x)))
 126     (if (null? classes)
 127         (format #t "(No direct subclass)~%")
 128         (begin
 129           (format #t "Directs subclasses are:~%")
 130           (for-each (lambda (s)
 131                       (format #t "    ~A~%" (safe-class-name s)))
 132                     classes))))
 133
 134   ;; CPL
 135   (format #t "Class Precedence List is:~%")
 136   (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s)))
 137             (class-precedence-list x))
 138
 139   ;; Direct Methods
 140   (let ((methods (class-direct-methods x)))
 141     (if (null? methods)
 142         (format #t "(No direct method)~%")
 143         (begin
 144           (format #t "Class direct methods are:~%")
 145           (for-each describe methods))))
 146
 147 ;  (format #t "~%Field Initializers ~%    ")
 148 ;  (write (slot-ref x 'initializers)) (newline)
 149
 150 ;  (format #t "~%Getters and Setters~%    ")
 151 ;  (write (slot-ref x 'getters-n-setters)) (newline)
 152 )
 153
 154 ;;;
 155 ;;; Describe for generic functions
 156 ;;;
 157 (define-method (describe (x <generic>))
 158   (let ((name    (generic-function-name x))
 159         (methods (generic-function-methods x)))
 160     ;; Title
 161     (format #t "~S is a generic function. It's an instance of ~A.~%"
 162             name (safe-class-name (class-of x)))
 163     ;; Methods
 164     (if (null? methods)
 165         (format #t "(No method defined for ~S)~%" name)
 166         (begin
 167           (format #t "Methods defined for ~S~%" name)
 168           (for-each (lambda (x) (describe x #t)) methods)))))
 169
 170 ;;;
 171 ;;; Describe for methods
 172 ;;;
 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))
 177                                ((pair? args)
 178                                 (display #\space)
 179                                 (display (safe-class-name (car args)))
 180                                 (print-args (cdr args)))
 181                                (else
 182                                 (display #\space)
 183                                 (display (safe-class-name args))
 184                                 (newline))))))
 185
 186     ;; Title
 187     (format #t "    Method ~A~%" x)
 188
 189     ;; Associated generic
 190     (if (null? omit-generic)
 191       (let ((gf (method-generic-function x)))
 192         (if gf
 193             (format #t "\t     Generic: ~A~%" (generic-function-name gf))
 194             (format #t "\t(No generic)~%"))))
 195
 196     ;; GF specializers
 197     (format #t "\tSpecializers:")
 198     (print-args (method-specializers x))))
 199
 200 (provide 'describe)