-;;;; chars.test --- test suite for Guile's char functions -*- scheme -*-
+;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+;;;; 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
(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"
;; The following test makes sure that the evaluator distinguishes between
;; evaluator-internal instruction codes and characters.
(pass-if-exception "evaluating chars"
- exception:wrong-type-to-apply
- (eval '(#\0) (interaction-environment)))))
+ 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 "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 "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)))
+ "#\\◌͓")))))
HCoop / bpt / guile.git / blobdiff