~ chicken-core (master) b102bd5715067426e9212d7ff156853769a6a082
commit b102bd5715067426e9212d7ff156853769a6a082
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Mar 17 11:05:44 2026 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Mar 17 11:05:44 2026 +0100
allow arbitrary characters when defining read-syntax, fixed broken handling of parameterized read-syntax
diff --git a/library.scm b/library.scm
index 23874984..fb3e20bd 100644
--- a/library.scm
+++ b/library.scm
@@ -4597,7 +4597,7 @@ EOF
(set! chicken.base#keyword-style
(make-parameter #:suffix (lambda (x) (when x (##sys#check-keyword x 'keyword-style)) x)))
-(define ##sys#current-read-table (make-parameter (##sys#make-structure 'read-table #f #f #f)))
+(define ##sys#current-read-table (make-parameter (##sys#make-structure 'read-table '() '() '())))
(define ##sys#read-warning
(let ([string-append string-append])
@@ -5104,12 +5104,12 @@ EOF
(r-spaces)
(let* ((c (##sys#peek-char-0 port))
(srst (##sys#slot crt 1))
- (h (and (not (eof-object? c)) srst
- (##sys#slot srst (char->integer c)) ) ) )
- (if h
+ (h (and (not (eof-object? c))
+ (assq c srst))))
+ (if (and h (##sys#slot h 1))
;; then handled by read-table entry
(##sys#call-with-values
- (lambda () (h c port))
+ (lambda () ((##sys#slot h 1) c port))
(lambda xs (if (null? xs) (readrec) (car xs))))
;; otherwise chicken extended r5rs syntax
(case c
@@ -5154,12 +5154,12 @@ EOF
(else (##sys#read-error port "undefined datum" n))))
;; #<num> handled by parameterized # read-table entry?
((and (char? dchar2)
- spdrst
- (##sys#slot spdrst (char->integer dchar2))) =>
+ (let ((a (assq dchar2 spdrst)))
+ (and a (##sys#slot a 1) a))) =>
(lambda (h)
- (h (##sys#call-with-values
- (lambda () (h dchar2 port n))
- (lambda xs (if (null? xs) (readrec) (car xs)))))))
+ (##sys#call-with-values
+ (lambda () ((##sys#slot h 1) dchar2 port n))
+ (lambda xs (if (null? xs) (readrec) (car xs))))))
;; #<num>
((or (eq? dchar2 #\)) (char-whitespace? dchar2))
(##sys#sharp-number-hook port n))
@@ -5169,11 +5169,11 @@ EOF
"invalid parameterized read syntax"
c n dchar2) ) ) ))
(else (let* ((sdrst (##sys#slot crt 2))
- (h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) )
- (if h
+ (h (assq dchar sdrst)))
+ (if (and h (##sys#slot h 1))
;; then handled by # read-table entry
(##sys#call-with-values
- (lambda () (h dchar port))
+ (lambda () ((##sys#slot h 1) dchar port))
(lambda xs (if (null? xs) (readrec) (car xs))))
;; otherwise chicken extended R7RS syntax
(case (char-downcase dchar)
diff --git a/read-syntax.scm b/read-syntax.scm
index c7c3df62..30e05ee2 100644
--- a/read-syntax.scm
+++ b/read-syntax.scm
@@ -49,16 +49,16 @@
(if (symbol? chr)
(set-read-mark! chr proc)
(let ((crt (current-read-table)))
- (unless (##sys#slot crt slot)
- (##sys#setslot crt slot (##sys#make-vector 256 #f)))
(##sys#check-char chr loc)
- (let ((i (char->integer chr)))
- (##sys#check-range i 0 256 loc)
- (cond (proc
- (##sys#check-closure proc loc)
- (##sys#setslot (##sys#slot crt slot) i (wrap proc)))
- (else
- (##sys#setslot (##sys#slot crt slot) i #f)))))))
+ (let ((i (char->integer chr))
+ (a (assq chr (##sys#slot crt slot))))
+ (when proc
+ (##sys#check-closure proc loc)
+ (set! proc (wrap proc)))
+ (if a
+ (##sys#setslot a 1 proc)
+ (##sys#setslot crt slot
+ (cons (cons chr proc) (##sys#slot crt slot))))))))
(define set-read-syntax!
(syntax-setter
@@ -87,15 +87,15 @@
;;; Read-table operations:
(define (copy-read-table rt)
+ (define (copy lst)
+ (map (lambda (a) (cons (car a) (cdr a))) lst))
(##sys#check-structure rt 'read-table 'copy-read-table)
(##sys#make-structure
'read-table
- (let ((t1 (##sys#slot rt 1)))
- (and t1 (##sys#vector-resize t1 (##sys#size t1) #f)))
- (let ((t2 (##sys#slot rt 2)))
- (and t2 (##sys#vector-resize t2 (##sys#size t2) #f)))
- (let ((t3 (##sys#slot rt 3)))
- (and t3 (##sys#vector-resize t3 (##sys#size t3) #f)))))
+ (copy (##sys#slot rt 1))
+ (copy (##sys#slot rt 2))
+ (copy (##sys#slot rt 3))))
+
;;; SRFI-10:
diff --git a/tests/reader-tests.scm b/tests/reader-tests.scm
index 13dc7c31..939919d3 100644
--- a/tests/reader-tests.scm
+++ b/tests/reader-tests.scm
@@ -2,7 +2,7 @@
(import (only chicken.io read-line read-string)
(only chicken.port with-input-from-string with-output-to-string)
- (only chicken.read-syntax set-read-syntax! set-sharp-read-syntax!))
+ chicken.read-syntax)
(set-sharp-read-syntax! #\& (lambda (p) (read p) (values)))
(set-sharp-read-syntax! #\^ (lambda (p) (read p)))
@@ -23,3 +23,23 @@
(assert (string=? output "hi\nfoo\nbaz\nbye\n"))
(assert (string=? " ." (with-input-from-string "\x20;\u0020\U00000020\056" read-string)))
+
+(set-read-syntax! #\! #f)
+(assert (equal? '! (with-input-from-string "! " read)))
+
+;; unicode
+
+(set-read-syntax! #\⋄ (lambda (p) (vector (read p))))
+
+(assert (equal? '#(99) (with-input-from-string " ⋄99" read)))
+
+;; parameterized read-syntax
+
+(set-parameterized-read-syntax! #\&
+ (lambda (p n)
+ (let ((x (read p)))
+ (let loop ((n n))
+ (if (zero? n) '()
+ (cons x (loop (- n 1))))))))
+
+(assert (equal? '(4 4 4) (with-input-from-string "#3&4" read)))
Trap