cl-print.el: Reduce code duplication

While at it, fix a bug in `cl-print-object-contents` for strings,
where we forgot to pass `stream` to `princ` at one place and simplify
a `substring` call using a negative offset.

* lisp/emacs-lisp/cl-print.el (cl-print--cons-tail)
(cl-print--vector-contents, cl-print--struct-contents)
(cl-print--string-props): New functions, extracted from
`cl-print-object-contents`.
(cl-print-object, cl-print-object-contents): Use them.

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 61586526ca15a28e3a7a145cd852f74b27c180d0..9578d5564212edc85fea20446b14df1cb326ac3f 100644 (file)
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -66,8 +66,7 @@ delimiters."
   (if (and cl-print--depth (natnump print-level)
            (> cl-print--depth print-level))
       (cl-print-insert-ellipsis object 0 stream)
-    (let ((car (pop object))
-          (count 1))
+    (let ((car (pop object)))
       (if (and print-quoted
                (memq car '(\, quote function \` \,@ \,.))
                (consp object)
@@ -80,26 +79,12 @@ delimiters."
                    stream)
             (cl-print-object (car object) stream))
         (princ "(" stream)
-        (cl-print-object car stream)
-        (while (and (consp object)
-                    (not (cond
-                          (cl-print--number-table
-                           (numberp (gethash object cl-print--number-table)))
-                          ((memq object cl-print--currently-printing))
-                          (t (push object cl-print--currently-printing)
-                             nil))))
-          (princ " " stream)
-          (if (or (not (natnump print-length)) (> print-length count))
-              (cl-print-object (pop object) stream)
-            (cl-print-insert-ellipsis object print-length stream)
-            (setq object nil))
-          (cl-incf count))
-        (when object
-          (princ " . " stream) (cl-print-object object stream))
+        (cl-print--cons-tail car object stream)
         (princ ")" stream)))))
 
-(cl-defmethod cl-print-object-contents ((object cons) _start stream)
-  (let ((count 0))
+(defun cl-print--cons-tail (car object stream)
+  (let ((count 1))
+    (cl-print-object car stream)
     (while (and (consp object)
                 (not (cond
                       (cl-print--number-table
@@ -107,33 +92,27 @@ delimiters."
                       ((memq object cl-print--currently-printing))
                       (t (push object cl-print--currently-printing)
                          nil))))
-      (unless (zerop count)
-        (princ " " stream))
+      (princ " " stream)
       (if (or (not (natnump print-length)) (> print-length count))
           (cl-print-object (pop object) stream)
-        (cl-print-insert-ellipsis object print-length stream)
+        (cl-print-insert-ellipsis object t stream)
         (setq object nil))
       (cl-incf count))
     (when object
       (princ " . " stream) (cl-print-object object stream))))
 
+(cl-defmethod cl-print-object-contents ((object cons) _start stream)
+  (cl-print--cons-tail (car object) (cdr object) stream))
+
 (cl-defmethod cl-print-object ((object vector) stream)
   (if (and cl-print--depth (natnump print-level)
            (> cl-print--depth print-level))
       (cl-print-insert-ellipsis object 0 stream)
     (princ "[" stream)
-    (let* ((len (length object))
-           (limit (if (natnump print-length)
-                      (min print-length len) len)))
-      (dotimes (i limit)
-        (unless (zerop i) (princ " " stream))
-        (cl-print-object (aref object i) stream))
-      (when (< limit len)
-        (princ " " stream)
-        (cl-print-insert-ellipsis object limit stream)))
+    (cl-print--vector-contents object 0 stream)
     (princ "]" stream)))
 
-(cl-defmethod cl-print-object-contents ((object vector) start stream)
+(defun cl-print--vector-contents (object start stream)
   (let* ((len (length object))
          (limit (if (natnump print-length)
                     (min (+ start print-length) len) len))
@@ -146,6 +125,9 @@ delimiters."
       (princ " " stream)
       (cl-print-insert-ellipsis object limit stream))))
 
+(cl-defmethod cl-print-object-contents ((object vector) start stream)
+  (cl-print--vector-contents object start stream)) ;FIXME: η-redex!
+
 (cl-defmethod cl-print-object ((object hash-table) stream)
   (princ "#<hash-table " stream)
   (princ (hash-table-test object) stream)
@@ -232,24 +214,11 @@ into a button whose action shows the function's disassembly.")
            (> cl-print--depth print-level))
       (cl-print-insert-ellipsis object 0 stream)
     (princ "#s(" stream)
-    (let* ((class (cl-find-class (type-of object)))
-           (slots (cl--struct-class-slots class))
-           (len (length slots))
-           (limit (if (natnump print-length)
-                      (min print-length len) len)))
-      (princ (cl--struct-class-name class) stream)
-      (dotimes (i limit)
-        (let ((slot (aref slots i)))
-          (princ " :" stream)
-          (princ (cl--slot-descriptor-name slot) stream)
-          (princ " " stream)
-          (cl-print-object (aref object (1+ i)) stream)))
-      (when (< limit len)
-        (princ " " stream)
-        (cl-print-insert-ellipsis object limit stream)))
+    (princ (cl--struct-class-name (cl-find-class (type-of object))) stream)
+    (cl-print--struct-contents object 0 stream)
     (princ ")" stream)))
 
-(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
+(defun cl-print--struct-contents (object start stream)
   (let* ((class (cl-find-class (type-of object)))
          (slots (cl--struct-class-slots class))
          (len (length slots))
@@ -258,7 +227,7 @@ into a button whose action shows the function's disassembly.")
          (i start))
     (while (< i limit)
       (let ((slot (aref slots i)))
-        (unless (= i start) (princ " " stream))
+        (unless (and (= i start) (> i 0)) (princ " " stream))
         (princ ":" stream)
         (princ (cl--slot-descriptor-name slot) stream)
         (princ " " stream)
@@ -268,6 +237,9 @@ into a button whose action shows the function's disassembly.")
       (princ " " stream)
       (cl-print-insert-ellipsis object limit stream))))
 
+(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
+  (cl-print--struct-contents object start stream)) ;FIXME: η-redex!
+
 (cl-defmethod cl-print-object ((object string) stream)
   (unless stream (setq stream standard-output))
   (let* ((has-properties (or (text-properties-at 0 object)
@@ -294,28 +266,36 @@ into a button whose action shows the function's disassembly.")
                                             (- (point) 1) stream)))))
       ;; Print the property list.
       (when has-properties
-        (let* ((interval-limit (and (natnump print-length)
-                                    (max 1 (/ print-length 3))))
-               (interval-count 0)
-               (start-pos (if (text-properties-at 0 object)
-                              0 (next-property-change 0 object)))
-               (end-pos (next-property-change start-pos object len)))
-          (while (and (or (null interval-limit)
-                          (< interval-count interval-limit))
-                      (< start-pos len))
-            (let ((props (text-properties-at start-pos object)))
-              (when props
-                (princ " " stream) (princ start-pos stream)
-                (princ " " stream) (princ end-pos stream)
-                (princ " " stream) (cl-print-object props stream)
-                (cl-incf interval-count))
-              (setq start-pos end-pos
-                    end-pos (next-property-change start-pos object len))))
-          (when (< start-pos len)
-            (princ " " stream)
-            (cl-print-insert-ellipsis object (list start-pos) stream)))
+        (cl-print--string-props object 0 stream)
         (princ ")" stream)))))
 
+(defun cl-print--string-props (object start stream)
+  (let* ((first (not (eq start 0)))
+         (len (length object))
+         (interval-limit (and (natnump print-length)
+                              (max 1 (/ print-length 3))))
+         (interval-count 0)
+         (start-pos (if (text-properties-at start object)
+                        start (next-property-change start object)))
+         (end-pos (next-property-change start-pos object len)))
+    (while (and (or (null interval-limit)
+                    (< interval-count interval-limit))
+                (< start-pos len))
+      (let ((props (text-properties-at start-pos object)))
+        (when props
+          (if first
+              (setq first nil)
+            (princ " " stream))
+          (princ start-pos stream)
+          (princ " " stream) (princ end-pos stream)
+          (princ " " stream) (cl-print-object props stream)
+          (cl-incf interval-count))
+        (setq start-pos end-pos
+              end-pos (next-property-change start-pos object len))))
+    (when (< start-pos len)
+      (princ " " stream)
+      (cl-print-insert-ellipsis object (list start-pos) stream))))
+
 (cl-defmethod cl-print-object-contents ((object string) start stream)
   ;; If START is an integer, it is an index into the string, and the
   ;; ellipsis that needs to be expanded is part of the string.  If
@@ -328,35 +308,13 @@ into a button whose action shows the function's disassembly.")
                           (min (+ start print-length) len) len))
                (substr (substring-no-properties object start limit))
                (printed (prin1-to-string substr))
-               (trimmed (substring printed 1 (1- (length printed)))))
-          (princ trimmed)
+               (trimmed (substring printed 1 -1)))
+          (princ trimmed stream)
           (when (< limit len)
             (cl-print-insert-ellipsis object limit stream)))
 
       ;; Print part of the property list.
-      (let* ((first t)
-             (interval-limit (and (natnump print-length)
-                                  (max 1 (/ print-length 3))))
-             (interval-count 0)
-             (start-pos (car start))
-             (end-pos (next-property-change start-pos object len)))
-        (while (and (or (null interval-limit)
-                        (< interval-count interval-limit))
-                    (< start-pos len))
-          (let ((props (text-properties-at start-pos object)))
-            (when props
-              (if first
-                  (setq first nil)
-                (princ " " stream))
-              (princ start-pos stream)
-              (princ " " stream) (princ end-pos stream)
-              (princ " " stream) (cl-print-object props stream)
-              (cl-incf interval-count))
-            (setq start-pos end-pos
-                  end-pos (next-property-change start-pos object len))))
-        (when (< start-pos len)
-          (princ " " stream)
-          (cl-print-insert-ellipsis object (list start-pos) stream))))))
+      (cl-print--string-props object (car start) stream))))
 
 ;;; Circularity and sharing.