Improve printing support for editor objects.

diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm
index 0299dc41c49b269d43e939e8c454c82eb93bbb79..eb3c1b4867326ab3c3a16c07e0038160dfa4313d 100644 (file)
--- a/src/edwin/bufwin.scm
+++ b/src/edwin/bufwin.scm
@@ -496,18 +496,21 @@ USA.
 (define-integrable (%set-window-debug-trace! window procedure)
   (with-instance-variables buffer-window window (procedure)
     (set! debug-trace procedure)))
+
+(define-print-method (class-predicate buffer-window)
+  (standard-print-method 'buffer-window
+    (lambda (window)
+      (list (%window-buffer window)))))
 \f
 ;;;; Outlines
 
 (define-structure (outline
                   (constructor %make-outline)
                   (print-procedure
-                   (bracketed-print-method 'OUTLINE
-                     (lambda (outline port)
-                       (write-string "index: " port)
-                       (write (outline-index-length outline) port)
-                       (write-string " y: " port)
-                       (write (outline-y-size outline) port)))))
+                   (standard-print-method 'outline
+                     (lambda (outline)
+                       (list (list 'index (outline-index-length outline))
+                             (list 'y (outline-y-size outline)))))))
   ;; The number of characters in the text line.  This is exclusive of
   ;; the newlines at the line's beginning and end, if any.
   index-length
@@ -570,16 +573,13 @@ USA.
 (define-structure (o3
                   (constructor %make-o3)
                   (print-procedure
-                   (bracketed-print-method 'O3
-                     (lambda (o3 port)
-                       (write-string "index: " port)
-                       (write (o3-index o3) port)
-                       (write-string " y: " port)
-                       (write (o3-y o3) port)
-                       (if (outline? (o3-outline o3))
-                           (begin
-                             (write-string " " port)
-                             (write (o3-outline o3) port)))))))
+                   (standard-print-method 'o3
+                     (lambda (o3)
+                       (cons* (list 'index (o3-index o3))
+                              (list 'y (o3-y o3))
+                              (if (outline? (o3-outline o3))
+                                  (list (o3-outline o3))
+                                  '()))))))
   outline
   index
   y)

diff --git a/src/edwin/class.scm b/src/edwin/class.scm
index ac530bf84386716c1a6d25e42e5db4865c7bcdcb..5d37c90b3b436752859c2b0a1e0b79a223819d7b 100644 (file)
--- a/src/edwin/class.scm
+++ b/src/edwin/class.scm
@@ -36,11 +36,17 @@ USA.
 ;;; ******************************************************************
 \f
 (define-structure (class (constructor %make-class))
-  (name false read-only true)
-  (superclass false read-only true)
+  (name #f read-only #t)
+  (superclass #f read-only #t)
   object-size
   instance-transforms
-  (methods false read-only true))
+  (methods #f read-only #t)
+  (predicate #f read-only #t))
+
+(define-print-method class?
+  (standard-print-method 'class
+    (lambda (class)
+      (list (class-name class)))))
 
 (define (class-method class name)
   (class-methods/ref (class-methods class) name))
@@ -78,7 +84,7 @@ USA.
 (define (make-object class)
   (if (not (class? class))
       (error:wrong-type-argument class "class" 'MAKE-OBJECT))
-  (let ((object (make-vector (class-object-size class) false)))
+  (let ((object (make-vector (class-object-size class) #f)))
     (vector-set! object 0 class)
     object))
 
@@ -86,11 +92,17 @@ USA.
   (and (vector? object)
        (not (zero? (vector-length object)))
        (class? (vector-ref object 0))))
+(register-predicate! object? 'object)
+
+(define-print-method object?
+  (standard-print-method
+      (lambda (object)
+       (class-name (object-class object)))))
 
 (define (object-of-class? class object)
   (and (vector? object)
-       (not (zero? (vector-length object)))
-       (eq? class (vector-ref object 0))))
+       (not (fix:= 0 (vector-length object)))
+       (eq? class (object-class object))))
 
 (define-integrable (object-class object)
   (vector-ref object 0))

diff --git a/src/edwin/clscon.scm b/src/edwin/clscon.scm
index f2701ad366a5ce476fedd8860fbe18dbab7f1c32..924ccbbacf200e6b27857f5401dcf2cc5e0a3162 100644 (file)
--- a/src/edwin/clscon.scm
+++ b/src/edwin/clscon.scm
@@ -43,24 +43,31 @@ USA.
        (transforms (make-instance-transforms superclass variables)))
     (let ((make-class
           (lambda ()
-            (let ((class
-                   (%make-class name
-                                superclass
-                                object-size
-                                transforms
-                                (cons '()
-                                      (and superclass
-                                           (class-methods superclass))))))
-              (named-structure/set-tag-description! class
-                (new-make-define-structure-type
-                 'VECTOR
-                 name
-                 (list->vector (map car transforms))
-                 (list->vector (map cdr transforms))
-                 (make-vector (length transforms) (lambda () #f))
-                 class
-                 object-size))
-              class))))
+            (define class
+              (%make-class name
+                           superclass
+                           object-size
+                           transforms
+                           (cons '()
+                                 (and superclass
+                                      (class-methods superclass)))
+                           (lambda (object)
+                             (object-of-class? class object))))
+            (named-structure/set-tag-description! class
+              (new-make-define-structure-type
+               'VECTOR
+               name
+               (list->vector (map car transforms))
+               (list->vector (map cdr transforms))
+               (make-vector (length transforms) (lambda () #f))
+               class
+               object-size))
+            (register-predicate! (class-predicate class) name
+                                 '<=
+                                 (if superclass
+                                     (class-predicate superclass)
+                                     object?))
+            class)))
       (if (not entry)
          (let ((class (make-class)))
            (set! class-descriptors (cons (cons name class) class-descriptors))

diff --git a/src/edwin/window.scm b/src/edwin/window.scm
index 543935498d3efd4e3580f927f6c1be45ee58d153..eed93a76065f4ce62dd678331e103fc803166182 100644 (file)
--- a/src/edwin/window.scm
+++ b/src/edwin/window.scm
@@ -371,17 +371,14 @@ USA.
   (vector-set! inferior 4 redisplay-flags))
 
 (define-print-method %inferior?
-  (bracketed-print-method 'inferior
-    (lambda (inferior port)
-      (write-string " " port)
-      (write (inferior-window inferior) port)
-      (write-string " x,y=(" port)
-      (write (inferior-x-start inferior) port)
-      (write-string "," port)
-      (write (inferior-y-start inferior) port)
-      (write-string ")" port)
-      (if (inferior-needs-redisplay? inferior)
-         (write-string " needs-redisplay" port)))))
+  (standard-print-method 'inferior
+    (lambda (inferior)
+      (cons* (inferior-window inferior)
+            (list (inferior-x-start inferior)
+                  (inferior-y-start inferior))
+            (if (inferior-needs-redisplay? inferior)
+                (list 'needs-redisplay)
+                '())))))
 
 (define (inferior-copy inferior)
   (%make-inferior (inferior-window inferior)