home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / oop / goops / describe.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  7.3 KB  |  226 lines
  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.  
  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")
  226.