~ chicken-core (master) 12feb07de2f3c2362934bcce665b0892ce8a4981
commit 12feb07de2f3c2362934bcce665b0892ce8a4981
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jun 28 23:22:29 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jun 28 23:22:29 2026 +0200
char-name: allow removing existing definition
diff --git a/NEWS b/NEWS
index 3f1296d3..c30dd083 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,7 @@
now fully equivalent to SRFI-4 u8vectors.
- The read-syntax for blobs (`#${...}') has been removed. Bytevectors
can be read using `#u8(...)' or `#u8"..."'.
+ - `char-name' now allows removing a named character definition.
- `open-input-file' and `open-output-file' accept a file encoding,
supported are currently UTF-8 (the default) and Latin-1 (ISO-8859-1).
- `file-read', `file-write', 'set-pseudo-random-seed!' and `random-bytes'
diff --git a/library.scm b/library.scm
index 094d57b1..f0336828 100644
--- a/library.scm
+++ b/library.scm
@@ -3818,42 +3818,54 @@ EOF
(set! chicken.base#char-name
(let ((chars-to-names (make-vector char-name-table-size '()))
- (names-to-chars '()))
+ (names-to-chars '()))
(define (lookup-char c)
- (let* ([code (char->integer c)]
- [key (##core#inline "C_fixnum_modulo" code char-name-table-size)] )
- (let loop ([b (##sys#slot chars-to-names key)])
- (and (pair? b)
- (let ([a (##sys#slot b 0)])
- (if (eq? (##sys#slot a 0) c)
- a
- (loop (##sys#slot b 1)) ) ) ) ) ) )
- (lambda (x . y)
- (let ([chr (if (pair? y) (car y) #f)])
- (cond [(char? x)
- (and-let* ([a (lookup-char x)])
- (##sys#slot a 1) ) ]
- [chr
- (##sys#check-symbol x 'char-name)
- (##sys#check-char chr 'char-name)
- (when (fx< (##sys#size (##sys#slot x 1)) 2)
- (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
- (let ([a (lookup-char chr)])
- (if a
- (let ([b (assq x names-to-chars)])
- (##sys#setslot a 1 x)
- (if b
- (##sys#setislot b 1 chr)
- (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )
- (let ([key (##core#inline "C_fixnum_modulo" (char->integer chr) char-name-table-size)])
- (set! names-to-chars (cons (cons x chr) names-to-chars))
- (##sys#setslot
- chars-to-names key
- (cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]
- [else
- (##sys#check-symbol x 'char-name)
- (and-let* ([a (assq x names-to-chars)])
- (##sys#slot a 1) ) ] ) ) ) ) )
+ (let* ((code (char->integer c))
+ (key (##core#inline "C_fixnum_modulo" code char-name-table-size)) )
+ (let loop ((b (##sys#slot chars-to-names key)))
+ (and (pair? b)
+ (let ((a (##sys#slot b 0)))
+ (if (eq? (##sys#slot a 0) c)
+ a
+ (loop (##sys#slot b 1)) ) ) ) ) ) )
+ (lambda (x #!optional (chr #:none))
+ (cond ((char? x)
+ (and-let* ((a (lookup-char x)))
+ (case chr
+ ((#:none)
+ (##sys#slot a 1) )
+ ((#f)
+ (##sys#setslot a 0 #f)
+ (##sys#setslot (assq (##sys#slot a 1) names-to-chars) 0 #f)
+ (##core#undefined))
+ (else
+ (##sys#signal-hook #:type-error 'char-name
+ "expected second boolean argument" chr) ))))
+ ((symbol? x)
+ (let ((a (assq x names-to-chars)))
+ (case chr
+ ((#:none) (and a (##sys#slot a 1)))
+ ((#f)
+ (when a (##sys#setslot a 0 #f))
+ (##core#undefined))
+ (else
+ (##sys#check-char chr 'char-name)
+ (when (fx< (##sys#size (##sys#slot x 1)) 2)
+ (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
+ (let ((a (lookup-char chr)))
+ (if a
+ (let ((b (assq x names-to-chars)))
+ (##sys#setslot a 1 x)
+ (if b
+ (##sys#setislot b 1 chr)
+ (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )
+ (let ((key (##core#inline "C_fixnum_modulo" (char->integer chr)
+ char-name-table-size)))
+ (set! names-to-chars (cons (cons x chr) names-to-chars))
+ (##sys#setslot
+ chars-to-names key
+ (cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ))))
+ (else (##sys#signal-hook #:type-error 'char-name "invalid argument type" x))))))
;; TODO: Use the character names here in the next release? Or just
;; use the numbers everywhere, for clarity?
diff --git a/manual/Module (chicken base) b/manual/Module (chicken base)
index b1442c5b..a4394360 100644
--- a/manual/Module (chicken base)
+++ b/manual/Module (chicken base)
@@ -615,7 +615,7 @@ to {{identity}}.
==== char-name
-<procedure>(char-name SYMBOL-OR-CHAR [CHAR])</procedure>
+<procedure>(char-name SYMBOL-OR-CHAR [CHAR-OR-FALSE])</procedure>
This procedure can be used to inquire about character names or to
define new ones. With a single argument the behavior is as follows:
@@ -625,10 +625,13 @@ under this name. If {{SYMBOL-OR-CHAR}} is a character, then the
name of the character is returned as a symbol, or {{#f}} if the
character has no associated name.
-If the optional argument {{CHAR}} is provided, then
+If the optional argument {{CHAR-OR-FALSE}} is provided and a character, then
{{SYMBOL-OR-CHAR}} should be a symbol that will be the new name of
the given character. If multiple names designate the same character,
-then the {{write}} will use the character name that was defined last.
+then {{write}} will use the character name that was defined last.
+If {{CHAR-OR-FALSE}} is {{#f}} instead, then {{SYMBOL-OR-CHAR}}
+may designate a symbol naming a character or a character and any
+defined character name for it will be removed.
<enscript highlight=scheme>
(char-name 'space) ==> #\space
@@ -638,6 +641,8 @@ then the {{write}} will use the character name that was defined last.
(char-name 'bell (integer->char 7))
(char-name 'bell) ==> #\bell
(char->integer (char-name 'bell)) ==> 7
+(char-name 'bell #f)
+(char-name 'bell) ==> #f
</enscript>
Trap