mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
6dce942c46
* libguile/strports.c (scm_mkstrport): Use UTF-8; ignore
%default-port-encoding. Rename 'str_len' and 'c_pos' to
'num_bytes' and 'c_byte_pos'. Interpret 'pos' argument
as a character index instead of a byte index.
* module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-6 to the
list of core features.
* module/srfi/srfi-6.scm (open-input-string, open-output-string): Simply
re-export these, since the core versions are now compliant.
* doc/ref/api-io.texi (String Ports): Remove text that describes
non-compliant behavior of string ports with regard to encoding.
* doc/ref/srfi-modules.texi (SRFI-0): Add srfi-6 to the list of
core features.
(SRFI-6): Remove text that mentions non-compliant behavior of
core string ports.
* module/ice-9/format.scm (format):
* module/ice-9/pretty-print.scm (truncated-print):
* module/rnrs/io/ports.scm (open-string-input-port,
open-string-output-port):
* test-suite/test-suite/lib.scm (format-test-name):
* test-suite/tests/chars.test ("combining accent is pretty-printed",
"combining X is pretty-printed"):
* test-suite/tests/ecmascript.test (eread, eread/1):
* test-suite/tests/rdelim.test:
* test-suite/tests/reader.test (read-string):
* test-suite/tests/regexp.test:
* test-suite/tests/srfi-105.test (read-string): Don't set
%default-port-encoding before creating string ports.
* benchmark-suite/benchmarks/ports.bm (%latin1-port): Use
'set-port-encoding!' to set the string port encoding.
(%utf8/ascii-port, %utf8/wide-port, "rdelim"): Don't set
%default-port-encoding before creating string ports.
* test-suite/tests/r6rs-ports.test ("lookahead-u8 non-ASCII"): Don't set
%default-port-encoding before creating string ports.
("put-bytevector with UTF-16 string port", "put-bytevector with
wrong-encoding string port"): Use 'set-port-encoding!' to set the
string port encoding.
* test-suite/tests/print.test (tprint): Use 'set-port-encoding!' to set
the string port encoding.
("truncated-print"): Use 'pass-if-equal'.
* test-suite/tests/ports.test ("encoding failure leads to exception",
"%default-port-encoding is honored", "peek-char [latin-1]", "peek-char
[utf-8]", "peek-char [utf-16]"): Remove tests.
("%default-port-encoding is ignored", "peek-char"): Add tests.
("suitable encoding [latin-1]", "suitable encoding [latin-3]",
"wrong encoding, error", "wrong encoding, substitute",
"wrong encoding, escape"): Use 'set-port-encoding!' to set the
string port encoding.
("%default-port-encoding, wrong encoding"): Rewrite to use
a file port instead of a string port.
326 lines
9 KiB
Scheme
326 lines
9 KiB
Scheme
;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
|
|
;;;; Greg J. Badros <gjb@cs.washington.edu>
|
|
;;;;
|
|
;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 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))
|
|
|
|
(pass-if "char=? #\\A #\\a"
|
|
(not (char=? #\A #\a)))
|
|
|
|
(pass-if "char=? #\\A #\\B"
|
|
(not (char=? #\A #\B)))
|
|
|
|
(pass-if "char=? #\\B #\\A"
|
|
(not (char=? #\A #\B)))
|
|
|
|
;; char<?
|
|
(pass-if "char<? #\\A #\\A"
|
|
(not (char<? #\A #\A)))
|
|
|
|
(pass-if "char<? #\\A #\\a"
|
|
(char<? #\A #\a))
|
|
|
|
(pass-if "char<? #\\A #\\B"
|
|
(char<? #\A #\B))
|
|
|
|
(pass-if "char<? #\\B #\\A"
|
|
(not (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))
|
|
|
|
(pass-if "char<=? #\\B #\\A"
|
|
(not (char<=? #\B #\A)))
|
|
|
|
;; char>?
|
|
(pass-if "char>? #\\A #\\A"
|
|
(not (char>? #\A #\A)))
|
|
|
|
(pass-if "char>? #\\A #\\a"
|
|
(not (char>? #\A #\a)))
|
|
|
|
(pass-if "char>? #\\A #\\B"
|
|
(not (char>? #\A #\B)))
|
|
|
|
(pass-if "char>? #\\B #\\A"
|
|
(char>? #\B #\A))
|
|
|
|
;; char>=?
|
|
(pass-if "char>=? #\\A #\\A"
|
|
(char>=? #\A #\A))
|
|
|
|
(pass-if "char>=? #\\A #\\a"
|
|
(not (char>=? #\A #\a)))
|
|
|
|
(pass-if "char>=? #\\A #\\B"
|
|
(not (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))
|
|
|
|
(pass-if "char-ci=? #\\A #\\B"
|
|
(not (char-ci=? #\A #\B)))
|
|
|
|
(pass-if "char-ci=? #\\B #\\A"
|
|
(not (char-ci=? #\A #\B)))
|
|
|
|
;; char-ci<?
|
|
(pass-if "char-ci<? #\\A #\\A"
|
|
(not (char-ci<? #\A #\A)))
|
|
|
|
(pass-if "char-ci<? #\\A #\\a"
|
|
(not (char-ci<? #\A #\a)))
|
|
|
|
(pass-if "char-ci<? #\\A #\\B"
|
|
(char-ci<? #\A #\B))
|
|
|
|
(pass-if "char-ci<? #\\B #\\A"
|
|
(not (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))
|
|
|
|
(pass-if "char-ci<=? #\\B #\\A"
|
|
(not (char-ci<=? #\B #\A)))
|
|
|
|
;; char-ci>?
|
|
(pass-if "char-ci>? #\\A #\\A"
|
|
(not (char-ci>? #\A #\A)))
|
|
|
|
(pass-if "char-ci>? #\\A #\\a"
|
|
(not (char-ci>? #\A #\a)))
|
|
|
|
(pass-if "char-ci>? #\\A #\\B"
|
|
(not (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))
|
|
|
|
(pass-if "char-ci>=? #\\A #\\B"
|
|
(not (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-output-to-string (lambda () (write accent)))
|
|
"#\\◌̏")))
|
|
|
|
(pass-if "combining X is pretty-printed"
|
|
(let ((x (integer->char #x0353))) ; COMBINING X BELOW
|
|
(string=?
|
|
(with-output-to-string (lambda () (write x)))
|
|
"#\\◌͓")))))
|