[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

fixing the display operation for vectors and lists



The following piece of code changes the way the display operation works
for lists and vectors so that the elements of the list or vector will
also be displayed (versus being printed, which is what currently happens).
This makes more sense to me, and the original code looks like this was
intended, but never quite implemented (write-pair had the parameter
slashify? but never used it).

The code should be compiled and loaded into t-implementation-env.  The
powers that be might consider including this code into the fix file
loaded at start-up.

Thanks to Richard Kelsey for helping me out with this.

---------------------------------------
(herald fix-display
        (env tsys)
        (syntax-table (env-syntax-table t-implementation-env)))

;;; This fixes the way the display operation is handled by lists and
;;; vectors, so that the elements of the lists and vectors are also
;;; "display"ed instead of "print"ing them.

;;; Only change was to add the variable pr-or-dpy used to print atoms.
(define (write-pair port obj level slashify?)
  (let ((pr-or-dpy (if slashify? print display))
        (writec (if (iob? port) vm-write-char write-char))
        (writes (if (iob? port) vm-write-string write-string)))
    (cond ((null? obj)
           (writec port *list-begin-char*)
           (writec port *list-end-char*))
          ((atom? obj)               (pr-or-dpy obj port))
          ((not (reasonable? obj))   (print-random obj port))
          ((fx> level *print-level*) (writes port print-level-excess))
          (else
           (writec port *list-begin-char*)
           (iterate loop ((l obj) (n 0) (flag '#f))
             (cond ((atom? l)
                    (cond ((not (null? l))
                           (space port)
                           (writec port dot-char)
                           (space port)
                           (write-pair port l (fx+ level 1) slashify?))))
                   (else
                    (if flag (space port))
                    (cond ((fx>= n *print-length*)
                           (writes port print-length-excess))
                          (else
                           (write-pair port (car l) (fx+ level 1) slashify?)
                           (loop (cdr l) (fx+ n 1) '#t))))))
           (writec port *list-end-char*)))))

(define-handler general-vector
  (object nil
    ((hash self)
     (do ((i 0 (fx+ i 1))
          (h 0 (fx+ h (hash (vref self i)))))
         ((fx>= h (vector-length self)) h)))
    ((crawl-exhibit self)
     (exhibit-standard-extend self (vector-length self) 0 0))
    ((maybe-crawl-component self command)
     (cond ((and (nonnegative-fixnum? command)
                 (fx< command (vector-length self)))
            (crawl-push (vref self command)))
           (else nil)))
    ((print obj port)
     (p-or-d-general-vector obj port print))
    ((display obj port)
     (p-or-d-general-vector obj port display))))

;;; print or display general-vector
(define (p-or-d-general-vector obj port pr-or-dpy)
  (write-char port *dispatch-char*)
  (write-char port *list-begin-char*)
  (iterate loop ((flag nil)
                 (i 0))
    (cond ((fx>= i (vector-length obj)))
          (else
           (if flag (space port))
           (cond ((fx>= i *print-length*)
                  (write-string port print-length-excess))
                 (else
                  (pr-or-dpy (vref obj i) port)
                  (loop t (fx+ i 1)))))))
  (write-char port *list-end-char*))
---------------------------------------

That's all,
Duke
-------