mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
33d92fe6ca
This had been removed by commit 07f49ac786
("Factorize and optimize `write' for strings and characters.").
Thanks Mike!
* libguile/print.c (write_combining_character): New procedure.
(write_character): Use it.
* test-suite/tests/chars.test ("basic char handling")["combining accent
is pretty-printed", "combining X is pretty-printed"]: New tests.
* test-suite/tests/encoding-iso88591.test ("characters")["write A
followed by combining accent"]: New test.
* test-suite/tests/encoding-utf8.test ("characters")["write A followed
by combining accent"]: New test.
328 lines
9.1 KiB
Scheme
328 lines
9.1 KiB
Scheme
;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
|
|
;;;; Greg J. Badros <gjb@cs.washington.edu>
|
|
;;;;
|
|
;;;; Copyright (C) 2000, 2006, 2009, 2010 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
(use-modules (test-suite lib))
|
|
|
|
(define exception:wrong-type-to-apply
|
|
(cons 'misc-error "^Wrong type to apply:"))
|
|
|
|
(define exception:unknown-character-name
|
|
(cons #t "unknown character"))
|
|
|
|
(define exception:out-of-range-octal
|
|
(cons #t "out-of-range"))
|
|
|
|
|
|
(with-test-prefix "basic char handling"
|
|
|
|
(with-test-prefix "evaluator"
|
|
|
|
;; The following test makes sure that the evaluator distinguishes between
|
|
;; evaluator-internal instruction codes and characters.
|
|
(pass-if-exception "evaluating chars"
|
|
exception:wrong-type-arg
|
|
(eval '(#\0) (interaction-environment))))
|
|
|
|
(with-test-prefix "comparisons"
|
|
|
|
;; char=?
|
|
(pass-if "char=? #\\A #\\A"
|
|
(char=? #\A #\A))
|
|
|
|
(expect-fail "char=? #\\A #\\a"
|
|
(char=? #\A #\a))
|
|
|
|
(expect-fail "char=? #\\A #\\B"
|
|
(char=? #\A #\B))
|
|
|
|
(expect-fail "char=? #\\B #\\A"
|
|
(char=? #\A #\B))
|
|
|
|
;; char<?
|
|
(expect-fail "char<? #\\A #\\A"
|
|
(char<? #\A #\A))
|
|
|
|
(pass-if "char<? #\\A #\\a"
|
|
(char<? #\A #\a))
|
|
|
|
(pass-if "char<? #\\A #\\B"
|
|
(char<? #\A #\B))
|
|
|
|
(expect-fail "char<? #\\B #\\A"
|
|
(char<? #\B #\A))
|
|
|
|
;; char<=?
|
|
(pass-if "char<=? #\\A #\\A"
|
|
(char<=? #\A #\A))
|
|
|
|
(pass-if "char<=? #\\A #\\a"
|
|
(char<=? #\A #\a))
|
|
|
|
(pass-if "char<=? #\\A #\\B"
|
|
(char<=? #\A #\B))
|
|
|
|
(expect-fail "char<=? #\\B #\\A"
|
|
(char<=? #\B #\A))
|
|
|
|
;; char>?
|
|
(expect-fail "char>? #\\A #\\A"
|
|
(char>? #\A #\A))
|
|
|
|
(expect-fail "char>? #\\A #\\a"
|
|
(char>? #\A #\a))
|
|
|
|
(expect-fail "char>? #\\A #\\B"
|
|
(char>? #\A #\B))
|
|
|
|
(pass-if "char>? #\\B #\\A"
|
|
(char>? #\B #\A))
|
|
|
|
;; char>=?
|
|
(pass-if "char>=? #\\A #\\A"
|
|
(char>=? #\A #\A))
|
|
|
|
(expect-fail "char>=? #\\A #\\a"
|
|
(char>=? #\A #\a))
|
|
|
|
(expect-fail "char>=? #\\A #\\B"
|
|
(char>=? #\A #\B))
|
|
|
|
(pass-if "char>=? #\\B #\\A"
|
|
(char>=? #\B #\A))
|
|
|
|
;; char-ci=?
|
|
(pass-if "char-ci=? #\\A #\\A"
|
|
(char-ci=? #\A #\A))
|
|
|
|
(pass-if "char-ci=? #\\A #\\a"
|
|
(char-ci=? #\A #\a))
|
|
|
|
(expect-fail "char-ci=? #\\A #\\B"
|
|
(char-ci=? #\A #\B))
|
|
|
|
(expect-fail "char-ci=? #\\B #\\A"
|
|
(char-ci=? #\A #\B))
|
|
|
|
;; char-ci<?
|
|
(expect-fail "char-ci<? #\\A #\\A"
|
|
(char-ci<? #\A #\A))
|
|
|
|
(expect-fail "char-ci<? #\\A #\\a"
|
|
(char-ci<? #\A #\a))
|
|
|
|
(pass-if "char-ci<? #\\A #\\B"
|
|
(char-ci<? #\A #\B))
|
|
|
|
(expect-fail "char-ci<? #\\B #\\A"
|
|
(char-ci<? #\B #\A))
|
|
|
|
;; char-ci<=?
|
|
(pass-if "char-ci<=? #\\A #\\A"
|
|
(char-ci<=? #\A #\A))
|
|
|
|
(pass-if "char-ci<=? #\\A #\\a"
|
|
(char-ci<=? #\A #\a))
|
|
|
|
(pass-if "char-ci<=? #\\A #\\B"
|
|
(char-ci<=? #\A #\B))
|
|
|
|
(expect-fail "char-ci<=? #\\B #\\A"
|
|
(char-ci<=? #\B #\A))
|
|
|
|
;; char-ci>?
|
|
(expect-fail "char-ci>? #\\A #\\A"
|
|
(char-ci>? #\A #\A))
|
|
|
|
(expect-fail "char-ci>? #\\A #\\a"
|
|
(char-ci>? #\A #\a))
|
|
|
|
(expect-fail "char-ci>? #\\A #\\B"
|
|
(char-ci>? #\A #\B))
|
|
|
|
(pass-if "char-ci>? #\\B #\\A"
|
|
(char-ci>? #\B #\A))
|
|
|
|
;; char-ci>=?
|
|
(pass-if "char-ci>=? #\\A #\\A"
|
|
(char-ci>=? #\A #\A))
|
|
|
|
(pass-if "char-ci>=? #\\A #\\a"
|
|
(char-ci>=? #\A #\a))
|
|
|
|
(expect-fail "char-ci>=? #\\A #\\B"
|
|
(char-ci>=? #\A #\B))
|
|
|
|
(pass-if "char-ci>=? #\\B #\\A"
|
|
(char-ci>=? #\B #\A)))
|
|
|
|
(with-test-prefix "categories"
|
|
|
|
(pass-if "char-alphabetic?"
|
|
(and (char-alphabetic? #\a)
|
|
(char-alphabetic? #\A)
|
|
(not (char-alphabetic? #\1))
|
|
(not (char-alphabetic? #\+))))
|
|
|
|
(pass-if "char-numeric?"
|
|
(and (not (char-numeric? #\a))
|
|
(not (char-numeric? #\A))
|
|
(char-numeric? #\1)
|
|
(not (char-numeric? #\+))))
|
|
|
|
(pass-if "char-whitespace?"
|
|
(and (not (char-whitespace? #\a))
|
|
(not (char-whitespace? #\A))
|
|
(not (char-whitespace? #\1))
|
|
(char-whitespace? #\space)
|
|
(not (char-whitespace? #\+))))
|
|
|
|
(pass-if "char-upper-case?"
|
|
(and (not (char-upper-case? #\a))
|
|
(char-upper-case? #\A)
|
|
(not (char-upper-case? #\1))
|
|
(not (char-upper-case? #\+))))
|
|
|
|
(pass-if "char-lower-case?"
|
|
(and (char-lower-case? #\a)
|
|
(not (char-lower-case? #\A))
|
|
(not (char-lower-case? #\1))
|
|
(not (char-lower-case? #\+))))
|
|
|
|
(pass-if "char-is-both? works"
|
|
(and
|
|
(not (char-is-both? #\?))
|
|
(not (char-is-both? #\newline))
|
|
(char-is-both? #\a)
|
|
(char-is-both? #\Z)
|
|
(not (char-is-both? #\1))))
|
|
|
|
(pass-if "char-general-category"
|
|
(and (eq? (char-general-category #\a) 'Ll)
|
|
(eq? (char-general-category #\A) 'Lu)
|
|
(eq? (char-general-category #\762) 'Lt))))
|
|
|
|
(with-test-prefix "integer"
|
|
|
|
(pass-if "char->integer"
|
|
(eqv? (char->integer #\A) 65))
|
|
|
|
(pass-if "integer->char"
|
|
(eqv? (integer->char 65) #\A))
|
|
|
|
(pass-if-exception "integer->char out of range, -1" exception:out-of-range
|
|
(integer->char -1))
|
|
|
|
(pass-if-exception "integer->char out of range, surrrogate"
|
|
exception:out-of-range
|
|
(integer->char #xd800))
|
|
|
|
(pass-if-exception "integer->char out of range, too big"
|
|
exception:out-of-range
|
|
(integer->char #x110000))
|
|
|
|
(pass-if-exception "octal out of range, surrrogate"
|
|
exception:out-of-range-octal
|
|
(with-input-from-string "#\\154000" read))
|
|
|
|
(pass-if-exception "octal out of range, too big"
|
|
exception:out-of-range-octal
|
|
(with-input-from-string "#\\4200000" read)))
|
|
|
|
(with-test-prefix "case"
|
|
|
|
(pass-if "char-upcase"
|
|
(eqv? (char-upcase #\a) #\A))
|
|
|
|
(pass-if "char-downcase"
|
|
(eqv? (char-downcase #\A) #\a))
|
|
|
|
(pass-if "char-titlecase"
|
|
(and (eqv? (char-titlecase #\a) #\A)
|
|
(eqv? (char-titlecase #\763) #\762))))
|
|
|
|
(with-test-prefix "charnames"
|
|
|
|
(pass-if "R5RS character names"
|
|
(and (eqv? #\space (integer->char #x20))
|
|
(eqv? #\newline (integer->char #x0A))))
|
|
|
|
(pass-if "R6RS character names"
|
|
(and (eqv? #\nul (integer->char #x00))
|
|
(eqv? #\alarm (integer->char #x07))
|
|
(eqv? #\backspace (integer->char #x08))
|
|
(eqv? #\tab (integer->char #x09))
|
|
(eqv? #\linefeed (integer->char #x0A))
|
|
(eqv? #\newline (integer->char #x0A))
|
|
(eqv? #\vtab (integer->char #x0B))
|
|
(eqv? #\page (integer->char #x0C))
|
|
(eqv? #\return (integer->char #x0D))
|
|
(eqv? #\esc (integer->char #x1B))
|
|
(eqv? #\space (integer->char #x20))
|
|
(eqv? #\delete (integer->char #x7F))))
|
|
|
|
(pass-if "R5RS character names are case insensitive"
|
|
(and (eqv? #\space #\ )
|
|
(eqv? #\SPACE #\ )
|
|
(eqv? #\Space #\ )
|
|
(eqv? #\newline (integer->char 10))
|
|
(eqv? #\NEWLINE (integer->char 10))
|
|
(eqv? #\Newline (integer->char 10))))
|
|
|
|
(pass-if "C0 control names are case insensitive"
|
|
(and (eqv? #\nul #\000)
|
|
(eqv? #\soh #\001)
|
|
(eqv? #\stx #\002)
|
|
(eqv? #\NUL #\000)
|
|
(eqv? #\SOH #\001)
|
|
(eqv? #\STX #\002)
|
|
(eqv? #\Nul #\000)
|
|
(eqv? #\Soh #\001)
|
|
(eqv? #\Stx #\002)))
|
|
|
|
(pass-if "alt charnames are case insensitive"
|
|
(eqv? #\null #\nul)
|
|
(eqv? #\NULL #\nul)
|
|
(eqv? #\Null #\nul))
|
|
|
|
(pass-if-exception "bad charname" exception:unknown-character-name
|
|
(with-input-from-string "#\\blammo" read))
|
|
|
|
(pass-if "R5RS character names are preferred write format"
|
|
(string=?
|
|
(with-output-to-string (lambda () (write #\space)))
|
|
"#\\space"))
|
|
|
|
(pass-if "C0 control character names are preferred write format"
|
|
(string=?
|
|
(with-output-to-string (lambda () (write #\soh)))
|
|
"#\\soh"))
|
|
|
|
(pass-if "combining accent is pretty-printed"
|
|
(let ((accent (integer->char #x030f))) ; COMBINING DOUBLE GRAVE ACCENT
|
|
(string=?
|
|
(with-fluids ((%default-port-encoding "UTF-8"))
|
|
(with-output-to-string (lambda () (write accent))))
|
|
"#\\◌̏")))
|
|
|
|
(pass-if "combining X is pretty-printed"
|
|
(let ((x (integer->char #x0353))) ; COMBINING X BELOW
|
|
(string=?
|
|
(with-fluids ((%default-port-encoding "UTF-8"))
|
|
(with-output-to-string (lambda () (write x))))
|
|
"#\\◌͓")))))
|