~ chicken-core (master) c81f65774bab00821c30f244c5e8dc3fb6d17945
commit c81f65774bab00821c30f244c5e8dc3fb6d17945
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 24 20:06:20 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 24 20:06:20 2026 +0200
procedures in (scheme write) respect print-length limit (if given)
diff --git a/library.scm b/library.scm
index bdbc48e5..c5e7bd46 100644
--- a/library.scm
+++ b/library.scm
@@ -31,7 +31,7 @@
(disable-interrupts)
(hide ##sys#dynamic-unwind
##sys#vector-resize ##sys#default-parameter-vector
- current-print-length setter-tag
+ setter-tag
##sys#print-exit ##sys#r7rs-exn-handlers
##sys#format-here-doc-warning
exit-in-progress cleanup-before-exit chicken.base#cleanup-tasks
@@ -5472,7 +5472,7 @@ EOF
(##sys#flush-output ##sys#standard-output)
(void)))
-(define current-print-length (make-parameter 0))
+(define ##sys#current-print-length (make-parameter 0))
(define ##sys#print-length-limit (make-parameter #f))
(define ##sys#print-exit (make-parameter #f))
@@ -5491,7 +5491,7 @@ EOF
(define (outstr port str)
(if length-limit
(let* ((len (string-length str))
- (cpp0 (current-print-length))
+ (cpp0 (##sys#current-print-length))
(cpl (fx+ cpp0 len)) )
(if (fx> cpl length-limit)
(let ((n (fx- length-limit cpp0)))
@@ -5499,7 +5499,7 @@ EOF
(outstr0 port "...")
((##sys#print-exit) (##sys#void)))
(outstr0 port str) )
- (current-print-length cpl) )
+ (##sys#current-print-length cpl) )
(outstr0 port str) ) )
(define (outstr0 port str)
@@ -5508,9 +5508,9 @@ EOF
(define (outchr port chr)
(when length-limit
- (let ((cpp0 (current-print-length)))
- (current-print-length (fx+ cpp0 1))
- (when (fx>= cpp0 length-limit)
+ (let ((cpp0 (##sys#current-print-length)))
+ (##sys#current-print-length (fx+ cpp0 1))
+ (when (fx> cpp0 length-limit)
(outstr0 port "...")
((##sys#print-exit) (##sys#void)))))
((##sys#slot (##sys#slot port 2) 2) port chr)) ; write-char
@@ -5758,7 +5758,7 @@ EOF
(lambda (return)
(parameterize ((##sys#print-length-limit limit)
(##sys#print-exit return)
- (current-print-length 0))
+ (##sys#current-print-length 0))
(thunk)))))))
diff --git a/r7lib.scm b/r7lib.scm
index d683905a..34564018 100644
--- a/r7lib.scm
+++ b/r7lib.scm
@@ -35,7 +35,7 @@
write-simple)
(import (rename scheme (display display-simple) (write write-simple))
(only chicken.base foldl when optional)
- (only chicken.fixnum fx+ fx= fx<= fx-))
+ (only chicken.fixnum fx+ fx- fx= fx<= fx>= fx> fx-))
(define (interesting? o)
(or (pair? o)
@@ -45,12 +45,34 @@
(define (uninteresting? o)
(not (interesting? o)))
+ (define (emit str p)
+ (let ((bv (##sys#slot str 0)))
+ ((##sys#slot (##sys#slot p 2) 3) p bv 0 (fx- (##sys#size bv) 1)))) ; write-bytevector
+
(define (display-char c p)
- ((##sys#slot (##sys#slot p 2) 2) p c))
+ (let ((n (##sys#print-length-limit)))
+ (when n
+ (let ((p (##sys#current-print-length)))
+ (##sys#current-print-length (fx+ p 1))
+ (when (fx> p n)
+ (emit "..." p)
+ ((##sys#print-exit) (##sys#void)))))
+ ((##sys#slot (##sys#slot p 2) 2) p c))) ; write-char
(define (display-string s p)
- (let ((bv (##sys#slot s 0)))
- ((##sys#slot (##sys#slot p 2) 3) p bv 0 (fx- (##sys#size bv) 1))))
+ (let ((n (##sys#print-length-limit)))
+ (if n
+ (let* ((len (string-length s))
+ (p (##sys#current-print-length))
+ (p2 (fx+ p len)))
+ (if (fx> p2 n)
+ (let ((m (fx- n p2)))
+ (when (fx> m 0) (emit (##sys#substring s 0 m) p))
+ (emit "..." p)
+ ((##sys#print-exit) (##sys#void)))
+ (emit s p))
+ (##sys#current-print-length p2))
+ (emit s p))))
;; Build an alist mapping `interesting?` objects to boolean values
;; indicating whether those objects occur shared in `o`.
Trap