From ae6b2a23b3fa219315acc9aea9ec4f43d320b9a8 Mon Sep 17 00:00:00 2001 From: felix Date: Sat, 24 Jun 2023 22:49:55 +0200 Subject: [PATCH] fix empty-string check when reading extended number vectors (reported by siiky) --- srfi-4.scm | 11 +++++++++-- tests/srfi-4-tests.scm | 4 ++++ 2 files changed, 13 insertions(+), 2 deletions(-) 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))))) -- 2.33.0