Small improvements to the writer

[software/python-on-guile.git] / modules / oop / pf-objects.scm

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index c270e1127021a971ddc716b5d160b15905dcea24..c036144c3c2fe7abb7fdbca60e772c3edea01cb4 100644 (file)
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -614,56 +614,40 @@ explicitly tell it to not update etc.
     (set-procedure-property! name 'pyclass c)
     name))
 
-(define-method (write (o <p>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
-
-(define-method (display (o <p>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
-
-(define-method (write (o <p>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
-
-(define-method (display (o <p>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
-
-(define-method (write (o <pf>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
-
-(define-method (display (o <pf>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
-
-(define-method (write (o <py>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
-
-(define-method (display (o <py>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
-
-
-(define-method (write (o <pyf>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
-
-(define-method (display (o <pyf>) . l)
-  (aif it (ref o '__repr__)
-       (apply it l)
-       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
+(define (get-class o)
+  (cond
+   ((procedure? o)
+    (aif it (procedure-property o 'pyclass)
+         it
+         (error "not an object ~a" o)))
+   (else
+    (class-of o))))
+
+(define (get-type o)
+  (cond
+   ((is-a? o <pyf>)
+    'pyf)
+   ((is-a? o <py>)
+    'py)
+   ((is-a? o <pf>)
+    'pf)
+   ((is-a? o <p>)
+    'p)
+   (else
+    'none)))
+
+(define (print o l)
+  (define port (if (pair? l) (car l) #t))
+  (format port
+          (aif it (ref o '__repr__)
+               (it)
+               (format #f
+                       "~a:~a" (get-type o) (ref o '__name__ 'None)))))
+
+(define-method (write (o <p>) . l) (print o l))
+(define-method (display (o <p>) . l) (print o l))
+
+
 
 (define-syntax-rule (define-python-class name parents code ...)
   (define name