167 lines
5.0 KiB

;;;; The DESCRIBE method (partly stolen fom Elk lib)
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 21-Mar-1993 14:33
;;;; Last file update: 3-Sep-1999 20:05 (eg)
(require "stklos")
(select-module STklos) ;; This file belongs to STklos module
(export describe) ;; Export the describe generic function
;;; describe for simple objects
(define-method describe ((x <top>))
(format #t "~W is " x)
((integer? x) (format #t "an integer"))
((real? x) (format #t "a real"))
((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"))
((pair? x) (format #t "a list"))
((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))))
((procedure? x) (format #t "a procedure"))
((environment? x) (format #t "an environment"))
((eof-object? x) (format #t "the end-of-file object"))
(else (format #t "an an instance of class ~A"
(class-name (class-of x)))))
(format #t ".~%"))
;;; describe for STklos instances
(define-method describe ((x <object>))
;; 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 "~W" (slot-ref x name))
(class-slots (class-of x)))
;;; Describe for classes
(define-method describe ((x <class>))
(format #t "~S is a class. It's an instance of ~A~%."
(class-name x) (class-name (class-of x)))
;; Super classes
(format #t "Superclasses are:~%")
(for-each (lambda (class) (format #t " ~A~%" (class-name class)))
(class-direct-supers x))
;; Direct slots
(let ((slots (class-direct-slots x)))
(if (null? slots)
(format #t "(No direct slot)~%")
(format #t "Directs slots are:~%")
(for-each (lambda (s)
(format #t " ~A~%" (slot-definition-name s)))
;; Direct subclasses
(let ((classes (class-direct-subclasses x)))
(if (null? classes)
(format #t "(No direct subclass)~%")
(format #t "Directs subclasses are:~%")
(for-each (lambda (s)
(format #t " ~A~%" (class-name s)))
;; CPL
(format #t "Class Precedence List is:~%")
(for-each (lambda (s) (format #t " ~A~%" (class-name s)))
(class-precedence-list x))
;; Direct Methods
(let ((methods (class-direct-methods x)))
(if (null? methods)
(format #t "(No direct method)~%")
(format #t "Class direct methods are:~%")
(for-each describe methods))))
; (format #t "~%Field Initializers ~% ")
; (write (slot-ref x 'initializers)) (newline)
; (format #t "~%Getters and Setters~% ")
; (write (slot-ref x 'getters-n-setters)) (newline)
;;; 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 (class-name (class-of x)))
;; Methods
(if (null? methods)
(format #t "(No method defined for ~S)~%" name)
(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 (class-name (car args)))
(print-args (cdr args)))
(else (display #\space)
(display (class-name args))
;; Title
(format #t " Method ~A~%" x)
;; Associated generic
(when (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")