Fix pprint column rounding issue

#941

ChangeLog

@@ -1,3 +1,8 @@
+2024-12-24  Shiro Kawai  <shiro@acm.org>
+
+	* lib/gauche/pputil.scm (do-layout-elements): Fix column rounding
+	  issue https://github.com/shirok/Gauche/issues/941
+
 2024-12-20  Shiro Kawai  <shiro@acm.org>
 
 	* lib/gauche/numioutil.scm: Move print-exact-decimal-point-number

lib/gauche/pputil.scm

@@ -94,6 +94,8 @@
 (define-inline (>=* a b) (and a b (>= a b)))
 (define-inline (-* a b . args)
   (and a b (if (null? args) (- a b) (apply -* (- a b) args))))
+(define-inline (+* a b . args)
+  (and a b (if (null? args) (+ a b) (apply +* (+ a b) args))))
 (define-inline (min* a b) (if a (if b (min a b) a) b))
 
 ;; Render OBJ into a string.  The resulting string is then used with
@@ -297,31 +299,35 @@
 ;; find out best fit.  Each layouter may be invoked more than once,
 ;; when retry happens.
 (define (do-layout-elements room memo elts)
-  (define (do-oneline r es strs)
+  (define (do-oneline r es strs first?)
     (match es
       [() (cons strs (-* room r))]
-      [(e . es) (match-let1 (s . w) (e room memo)
+      [(e . es) (match-let1 (s . w) (e r memo)
                   (cond [(not w) (do-linear room elts)] ;giveup
                         [(>* w room)                            ;too big
                          (do-fill room es (list* 'b s 'b strs))]
-                        [(>* w r)
+                        [(and first? (>* r w))
+                         (do-oneline (-*  r w) es (list* s 's strs) #f)]
+                        [(>* w (-* r 1))
                          (do-fill (-* room w) es (list* s 'b strs))]
                         [else
-                         (do-oneline (-* r w 1) es (list* s 's strs))]))]))
+                         (do-oneline (-* r w 1) es (list* s 's strs) #f)]))]))
   (define (do-fill r es strs)
     (match es
       [() (cons strs #f)]
-      [(e . es) (match-let1 (s . w) (e room memo)
+      [(e . es) (match-let1 (s . w) (e r memo)
                   (cond [(not w) (do-linear room elts)]
                         [(>* w (-* r 1))
-                         (do-fill (-* room w 1) es (list* s 'b strs))]
-                        [else (do-fill (-* r w 1) es (list* s 's strs))]))]))
+                         (do-fill (-* room w) es (list* s 'b strs))]
+                        [else
+                         (do-fill (-* r w 1) es (list* s 's strs))]))]))
   (define (do-linear r es)
     (cons (fold (^[e strs] (match-let1 (s . w) (e room memo) (list* s 'b strs)))
                 '() es)
           #f))
-  (match-let1 (s . w) (do-oneline room elts '())
-    (cons (cons ")" s) w)))
+
+  (match-let1 (s . w) (do-oneline room elts '() #t)
+    (cons (cons ")" s) (+* w 1))))
 
 ;; Render the nested list of strings.  Some trick: S's and b's right
 ;; after open paren are ignored.  S's right after b's are also ignored.

test/io2.scm

@@ -707,8 +707,8 @@
       [data2 '(Lorem (ipsum #(dolor (sit (amet . consectetur)))))]
       )
   (define (t name expect data . args)
-    (test* #"~|name| ~|args|" expect
-           (with-output-to-string (^[] (apply pprint data args)))))
+    (test*/diff #"~|name| ~|args|" expect
+                (with-output-to-string (^[] (apply pprint data args)))))
   (define elli (with-module gauche.internal (string-ellipsis)))
   (let-syntax
       ([t* (syntax-rules ()
@@ -763,6 +763,39 @@
        \n (ipsum #(dolor (sit #))))\n")
     ))
 
+;; Rounding error
+;; https://github.com/shirok/Gauche/issues/941
+(test*/diff "rounding"
+            "(abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc
+                     abc abc abc abc abc abc abc abc abc abc)
+"
+            (with-output-to-string (cut pprint (make-list 100 'abc)
+                                        :indent 20 :width 60)))
+
+;; some more rounding tests
+(let ((expected '("(abc)\n"
+                  "(abc abc)\n"
+                  "(abc abc\n abc)\n"
+                  "(abc abc\n abc abc)\n"
+                  "(abc abc\n abc abc\n abc)\n"
+                  "(abc abc\n abc abc\n abc abc)\n"
+                  "(abc abc\n abc abc\n abc abc\n abc)\n"
+                  "(abc abc\n abc abc\n abc abc\n abc abc)\n")))
+  (dotimes [i (length expected)]
+    (test*/diff #"rounding ~i"
+                (~ expected i)
+                (with-output-to-string
+                  (cut pprint (make-list (+ i 1) 'abc) :width 8))))
+  )
+
 (test* "no newline" "(a\n a)"
        (call-with-output-string
          (cut pprint '(a a) :width 3 :newline #f :port <>)))