diff options
Diffstat (limited to 'module/oop/goops/describe.scm')
-rw-r--r-- | module/oop/goops/describe.scm | 189 |
1 files changed, 189 insertions, 0 deletions
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm new file mode 100644 index 000000000..0428b4ba8 --- /dev/null +++ b/module/oop/goops/describe.scm @@ -0,0 +1,189 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009, 2015 Free Software Foundation, Inc. +;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +;;;; +;;;; This file was based upon describe.stklos from the STk distribution +;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops describe) + :use-module (oop goops) + :use-module (ice-9 session) + :use-module (ice-9 format) + :export (describe)) ; Export the describe generic function + +;;; +;;; describe for simple objects +;;; +(define-method (describe (x <top>)) + (format #t "~s is " x) + (cond + ((integer? x) (format #t "an integer")) + ((real? x) (format #t "a real")) + ((complex? x) (format #t "a complex number")) + ((null? x) (format #t "an empty list")) + ((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false))) + ((char? x) (format #t "a character, ascii value is ~s" + (char->integer x))) + ((symbol? x) (format #t "a symbol")) + ((list? x) (format #t "a list")) + ((pair? x) (if (pair? (cdr x)) + (format #t "an improper list") + (format #t "a pair"))) + ((string? x) (if (eqv? x "") + (format #t "an empty string") + (format #t "a string of length ~s" (string-length x)))) + ((vector? x) (if (eqv? x '#()) + (format #t "an empty vector") + (format #t "a vector of length ~s" (vector-length x)))) + ((eof-object? x) (format #t "the end-of-file object")) + (else (format #t "an unknown object (~s)" x))) + (format #t ".~%") + *unspecified*) + +(define-method (describe (x <procedure>)) + (let ((name (procedure-name x))) + (if name + (format #t "`~s'" name) + (display x)) + (display " is ") + (display (if name #\a "an anonymous")) + (display " procedure") + (display " with ") + (arity x))) + +;;; +;;; describe for GOOPS instances +;;; +(define (safe-class-name class) + (if (slot-bound? class 'name) + (class-name class) + class)) + +(define-method (describe (x <object>)) + (format #t "~S is an instance of class ~A~%" + x (safe-class-name (class-of x))) + + ;; print all the instance slots + (format #t "Slots are: ~%") + (for-each (lambda (slot) + (let ((name (slot-definition-name slot))) + (format #t " ~S = ~A~%" + name + (if (slot-bound? x name) + (format #f "~S" (slot-ref x name)) + "#<unbound>")))) + (class-slots (class-of x))) + *unspecified*) + +;;; +;;; Describe for classes +;;; +(define-method (describe (x <class>)) + (format #t "~S is a class. It's an instance of ~A~%" + (safe-class-name x) (safe-class-name (class-of x))) + + ;; Super classes + (format #t "Superclasses are:~%") + (for-each (lambda (class) (format #t " ~A~%" (safe-class-name class))) + (class-direct-supers x)) + + ;; Direct slots + (let ((slots (class-direct-slots x))) + (if (null? slots) + (format #t "(No direct slot)~%") + (begin + (format #t "Directs slots are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (slot-definition-name s))) + slots)))) + + + ;; Direct subclasses + (let ((classes (class-direct-subclasses x))) + (if (null? classes) + (format #t "(No direct subclass)~%") + (begin + (format #t "Directs subclasses are:~%") + (for-each (lambda (s) + (format #t " ~A~%" (safe-class-name s))) + classes)))) + + ;; CPL + (format #t "Class Precedence List is:~%") + (for-each (lambda (s) (format #t " ~A~%" (safe-class-name s))) + (class-precedence-list x)) + + ;; Direct Methods + (let ((methods (class-direct-methods x))) + (if (null? methods) + (format #t "(No direct method)~%") + (begin + (format #t "Class direct methods are:~%") + (for-each describe methods))))) + +;;; +;;; Describe for generic functions +;;; +(define-method (describe (x <generic>)) + (let ((name (generic-function-name x)) + (methods (generic-function-methods x))) + ;; Title + (format #t "~S is a generic function. It's an instance of ~A.~%" + name (safe-class-name (class-of x))) + ;; Methods + (if (null? methods) + (format #t "(No method defined for ~S)~%" name) + (begin + (format #t "Methods defined for ~S~%" name) + (for-each (lambda (x) (describe x #t)) methods))))) + +;;; +;;; Describe for methods +;;; +(define-method (describe (x <method>) . omit-generic) + (letrec ((print-args (lambda (args) + ;; take care of dotted arg lists + (cond ((null? args) (newline)) + ((pair? args) + (display #\space) + (display (safe-class-name (car args))) + (print-args (cdr args))) + (else + (display #\space) + (display (safe-class-name args)) + (newline)))))) + + ;; Title + (format #t " Method ~A~%" x) + + ;; Associated generic + (if (null? omit-generic) + (let ((gf (method-generic-function x))) + (if gf + (format #t "\t Generic: ~A~%" (generic-function-name gf)) + (format #t "\t(No generic)~%")))) + + ;; GF specializers + (format #t "\tSpecializers:") + (print-args (method-specializers x)))) + +(provide 'describe) |