;;;; describe-object-body.scm

;;

(define-generic describe-object)

(define-method (describe-object (x <object>) #!optional (port ##sys#standard-output))
  (let ((class (class-of x)))
    (fprintf port "instance of class ~A:~%" (class-name class))
    (let* ((nams (map car (class-slots class)))
           (strs (map (cut sprintf "~A" <>) nams)) ;non-string names possible!
           (lens (map string-length strs))
           (maxlen (+ 2 (apply max lens))) )
      (for-each
        (lambda (nam str len)
          (fprintf port "~A~A -> ~S~%" (make-string (- maxlen len)) str (slot-ref x nam)) )
        nams strs lens) ) ) )

(define-method (describe-object (x <primitive>) #!optional (port ##sys#standard-output))
  (fprintf port "instance of primitive class ~A: ~S~%"
    (class-name (class-of x)) x) )

(define-method (describe-object (x <class>) #!optional (port ##sys#standard-output))
  (fprintf port "class ~A (~A):~%" (class-name x) (class-name (class-of x)))
  (fprintf port "          Slots: ~A~%"
    (intersperse (map car (class-slots x)) #\,))
  (fprintf port "         Supers: ~A~%"
    (intersperse (map class-name (class-cpl x)) #\,))
  (fprintf port "   Direct Slots: ~A~%"
    (intersperse (map car (class-direct-slots x)) #\,))
  (fprintf port "  Direct Supers: ~A~%"
    (intersperse (map class-name (class-direct-supers x)) #\,)) )

(define-method (describe-object (x <generic>) #!optional (port ##sys#standard-output))
  (fprintf port "generic procedure ~A (~A):~%" (generic-name x) (class-name (class-of x)))
  (let ((methods (generic-methods x)))
    (fprintf port "  Specialized by ~A methods:~%" (length methods))
    (for-each
      (lambda (m)
        (fprintf port "  : ~A~%"
          (intersperse (map class-name (method-specializers m)) #\,)) )
      methods) ) )