home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / oop / goops / describe.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  6.0 KB  |  201 lines
  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.  
  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)
  201.