~ chicken-core (chicken-5) ad0c5a57deb21b069d5a778c1d0545f29b196f94

commit ad0c5a57deb21b069d5a778c1d0545f29b196f94
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jun 24 22:49:55 2023 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Mon Jun 26 11:43:37 2023 +0200

    fix empty-string check when reading extended number vectors
    
    (reported by siiky)
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/srfi-4.scm b/srfi-4.scm
index 8b990779..0d908f0c 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -612,6 +612,11 @@ EOF
 
 ;;; Read syntax:
 
+;; This code is too complicated. We try to avoid mapping over
+;; a potentially large list anc creating lots of garbage in the
+;; process, therefore the final result list is constructed 
+;; via destructive updates and thus rather inelegant yet avoids
+;; any re-consing unless elements are non-numeric.
 (define (canonicalize-number-list! lst1)
   (let loop ((lst lst1) (prev #f))
     (if (and (##core#inline "C_blockp" lst) 
@@ -619,7 +624,7 @@ EOF
         (let retry ((x (##sys#slot lst 0)))
           (cond ((char? x) (retry (##sys#char->utf8-string x)))
                 ((string? x)
-                 (if (eq? x "")
+                 (if (zero? (string-length x))
                      (loop (##sys#slot lst 1) prev)
                      (let loop2 ((ns (string->list x)) (prev prev))
                        (let ((n (cons (char->integer (##sys#slot ns 0))
@@ -632,7 +637,9 @@ EOF
                                (loop (##sys#slot lst 1) n)
                                (loop2 (##sys#slot ns 1) n)))))))
                 (else (loop (##sys#slot lst 1) lst))))
-        lst1)))
+        (cond (prev (##sys#setslot prev 1 '())
+                    lst1)
+              (else '())))))
 
 (set! ##sys#user-read-hook
   (let ([old-hook ##sys#user-read-hook]
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 7e0548cb..9fa498fc 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -163,6 +163,10 @@
 (let ((cases '(("#u8(1 2 #\\A)" #u8(1 2 65))
                ("#u8(\"abc\")" #u8(97 98 99))
                ("#u8\"abc\"" #u8(97 98 99))
+               ("#u8(\"\")" #u8())
+               ("#u8(\"\" \"a\")" #u8(97))
+               ("#u8(\"a\" \"\")" #u8(97))
+               ("#u8\"\"" #u8())
                ("#s8\"\"" #s8())
                ("#u64(\" \" #\\! 1 \"A\")" #u64(32 33 1 65))
                ("#u64(\" \" #\\! \"A\" 1)" #u64(32 33 65 1)))))