From 354a6bca8c85a10c8bc665d5e24ee423141795f8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 17 Dec 2022 19:35:07 -0800 Subject: [PATCH] Improve printing support for editor objects. --- src/edwin/bufwin.scm | 32 ++++++++++++++++---------------- src/edwin/class.scm | 24 ++++++++++++++++++------ src/edwin/clscon.scm | 43 +++++++++++++++++++++++++------------------ src/edwin/window.scm | 19 ++++++++----------- 4 files changed, 67 insertions(+), 51 deletions(-) diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm index 0299dc41c..eb3c1b486 100644 --- 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))))) ;;;; 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 ac530bf84..5d37c90b3 100644 --- a/src/edwin/class.scm +++ b/src/edwin/class.scm @@ -36,11 +36,17 @@ USA. ;;; ****************************************************************** (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 f2701ad36..924ccbbac 100644 --- 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 543935498..eed93a760 100644 --- 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) -- 2.47.3