Commits

Jim Ursetto committed 51689db Draft

use describe egg for non-coops, and describe-object for standard-class objects; describe procedure contents too

Comments (0)

Files changed (1)

describe-coops-mod.scm

+;; TODO: hook ,d with new describe call
+
 (use coops)
+(use (only srfi-1 fold))
 (use (only srfi-13 string-pad))
 ;;(use (prefix describe describe:))
 ;;(define describe:describe describe)
 
 (define-inline (symbol-length sym) (string-length (symbol->string sym)))
-(define-inline (*class-slots class) (slot-value class 'slots))
+(define-inline (class-slots class) (slot-value class 'slots))
 
 (define-generic (describe-object obj))
 
 (define-method (describe-object (obj #t) #!optional (out (current-output-port)))
   (let ((class (class-of obj)))
     (cond
-      ((eq? class #t)
-        ; specific in that obj used thru a coops interface
-        ; but might be misleading - (display obj out) perhaps?
-        (fprintf out "coops instance of class `#t': ~S~%" obj) )
-      (else
-        (fprintf out "coops instance of class `~A':~%" (class-name class))
-        (let* ((slots (*class-slots class))
-               (maxlen (fold (lambda (slot len) (fxmax (symbol-length slot) len)) 0 slots)) )
-          (for-each
-            (lambda (slot)
-              (display (string-pad (symbol->string slot) maxlen) out)
-              (display " : " out)
-              (if (slot-initialized? obj slot) (write (slot-value obj slot) out)
-                  (display "#<uninitialized>" out) )
-              (newline out) )
-            slots) ) ) ) ) )
+     ((eq? class #t)
+      (describe:describe obj out))
+     ;; Match objects with the metaclass of <standard-class>, i.e. those supporting slots
+     ;; and classname.  We don't specialize on <standard-object> because other object
+     ;; base classes having the standard metaclass should work as well, were you to
+     ;; create any.  This also works for metaclasses that subclass <standard-class>.
+     ((subclass? (class-of class) <standard-class>)
+      (fprintf out "coops instance of class ~A:~%" (class-name class))
+      (let* ((slots (class-slots class))
+             (maxlen (fold (lambda (slot len) (fxmax (symbol-length slot) len)) 0 slots)) )
+        (for-each
+         (lambda (slot)
+           (display "  ")
+           (display (string-pad (symbol->string slot) maxlen) out)
+           (display " : " out)
+           (if (slot-initialized? obj slot) (write (slot-value obj slot) out)
+               (display "#<uninitialized>" out) )
+           (newline out) )
+         slots)))
+     (else
+      ;; Handle case where metaclass is not a subclass of <standard-class>.
+      ;; Although it's possible to create such a class, it has to have all the
+      ;; usual slots (CPL, slots, etc.) of <standard-class> anyway, as make-class
+      ;; relies on them.  So this is not terribly useful.
+      ;; A contrived example of an object that would trigger this clause:
+      ;; (make (make-class <test> () (x y z)
+      ;;         (make-class <nonstdmeta> () (class-precedence-list slots classname initthunks))))
+      (fprintf out "coops instance of non-standard class~%")
+      (describe:describe obj out)))))
 
 (define-method (describe-object (prim <primitive-object>) #!optional (out (current-output-port)))
   (fprintf out "coops instance of primitive class ~A~%"
 
 (define-method (describe-object (proc <procedure>) #!optional (out (current-output-port)))
   (if (generic-procedure? proc)
-      (fprintf out "coops instance of `<generic-procedure>'~%")
-      (fprintf out "coops instance of primitive class `<procedure>'~%") ) )
+      (fprintf out "coops instance of <generic-procedure>~%")
+      (fprintf out "coops instance of primitive class <procedure>~%"))
+  (describe:describe proc out))
 
 (define-method (describe-object (class <standard-class>) #!optional (out (current-output-port)))
   (fprintf out "coops standard-class ~A~%" (class-name class))
 (define-class <human> () ((name "Anne O. Nymous")
                           favorite-drink))
 |#
+
+(define (describe obj #!optional (out (current-output-port)))
+  (describe-object obj out))
+
+