test-suite/tests/chars.test

   1 ;;;; chars.test --- Characters.       -*- coding: utf-8; mode: scheme; -*-
   2 ;;;; Greg J. Badros <gjb@cs.washington.edu>
   3 ;;;;
   4 ;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (use-modules (test-suite lib))
  21
  22 (define exception:wrong-type-to-apply
  23   (cons 'misc-error "^Wrong type to apply:"))
  24
  25 (define exception:unknown-character-name
  26   (cons #t "unknown character"))
  27
  28 (define exception:out-of-range-octal
  29   (cons #t "out-of-range"))
  30
  31
  32 (with-test-prefix "basic char handling"
  33
  34   (with-test-prefix "evaluator"
  35
  36     ;; The following test makes sure that the evaluator distinguishes between
  37     ;; evaluator-internal instruction codes and characters.
  38     (pass-if-exception "evaluating chars"
  39       exception:wrong-type-arg
  40       (eval '(#\0) (interaction-environment))))
  41
  42   (with-test-prefix "comparisons"
  43
  44     ;; char=?
  45     (pass-if "char=? #\\A #\\A"
  46       (char=? #\A #\A))
  47
  48     (pass-if "char=? #\\A #\\a"
  49       (not (char=? #\A #\a)))
  50
  51     (pass-if "char=? #\\A #\\B"
  52       (not (char=? #\A #\B)))
  53
  54     (pass-if "char=? #\\B #\\A"
  55       (not (char=? #\A #\B)))
  56
  57     ;; char<?
  58     (pass-if "char<? #\\A #\\A"
  59       (not (char<? #\A #\A)))
  60
  61     (pass-if "char<? #\\A #\\a"
  62       (char<? #\A #\a))
  63
  64     (pass-if "char<? #\\A #\\B"
  65       (char<? #\A #\B))
  66
  67     (pass-if "char<? #\\B #\\A"
  68       (not (char<? #\B #\A)))
  69
  70     ;; char<=?
  71     (pass-if "char<=? #\\A #\\A"
  72       (char<=? #\A #\A))
  73
  74     (pass-if "char<=? #\\A #\\a"
  75       (char<=? #\A #\a))
  76
  77     (pass-if "char<=? #\\A #\\B"
  78       (char<=? #\A #\B))
  79
  80     (pass-if "char<=? #\\B #\\A"
  81       (not (char<=? #\B #\A)))
  82
  83     ;; char>?
  84     (pass-if "char>? #\\A #\\A"
  85       (not (char>? #\A #\A)))
  86
  87     (pass-if "char>? #\\A #\\a"
  88       (not (char>? #\A #\a)))
  89
  90     (pass-if "char>? #\\A #\\B"
  91       (not (char>? #\A #\B)))
  92
  93     (pass-if "char>? #\\B #\\A"
  94       (char>? #\B #\A))
  95
  96     ;; char>=?
  97     (pass-if "char>=? #\\A #\\A"
  98       (char>=? #\A #\A))
  99
 100     (pass-if "char>=? #\\A #\\a"
 101       (not (char>=? #\A #\a)))
 102
 103     (pass-if "char>=? #\\A #\\B"
 104       (not (char>=? #\A #\B)))
 105
 106     (pass-if "char>=? #\\B #\\A"
 107       (char>=? #\B #\A))
 108
 109     ;; char-ci=?
 110     (pass-if "char-ci=? #\\A #\\A"
 111       (char-ci=? #\A #\A))
 112
 113     (pass-if "char-ci=? #\\A #\\a"
 114       (char-ci=? #\A #\a))
 115
 116     (pass-if "char-ci=? #\\A #\\B"
 117       (not (char-ci=? #\A #\B)))
 118
 119     (pass-if "char-ci=? #\\B #\\A"
 120       (not (char-ci=? #\A #\B)))
 121
 122     ;; char-ci<?
 123     (pass-if "char-ci<? #\\A #\\A"
 124       (not (char-ci<? #\A #\A)))
 125
 126     (pass-if "char-ci<? #\\A #\\a"
 127       (not (char-ci<? #\A #\a)))
 128
 129     (pass-if "char-ci<? #\\A #\\B"
 130       (char-ci<? #\A #\B))
 131
 132     (pass-if "char-ci<? #\\B #\\A"
 133       (not (char-ci<? #\B #\A)))
 134
 135     ;; char-ci<=?
 136     (pass-if "char-ci<=? #\\A #\\A"
 137       (char-ci<=? #\A #\A))
 138
 139     (pass-if "char-ci<=? #\\A #\\a"
 140       (char-ci<=? #\A #\a))
 141
 142     (pass-if "char-ci<=? #\\A #\\B"
 143       (char-ci<=? #\A #\B))
 144
 145     (pass-if "char-ci<=? #\\B #\\A"
 146       (not (char-ci<=? #\B #\A)))
 147
 148     ;; char-ci>?
 149     (pass-if "char-ci>? #\\A #\\A"
 150       (not (char-ci>? #\A #\A)))
 151
 152     (pass-if "char-ci>? #\\A #\\a"
 153       (not (char-ci>? #\A #\a)))
 154
 155     (pass-if "char-ci>? #\\A #\\B"
 156       (not (char-ci>? #\A #\B)))
 157
 158     (pass-if "char-ci>? #\\B #\\A"
 159       (char-ci>? #\B #\A))
 160
 161     ;; char-ci>=?
 162     (pass-if "char-ci>=? #\\A #\\A"
 163       (char-ci>=? #\A #\A))
 164
 165     (pass-if "char-ci>=? #\\A #\\a"
 166       (char-ci>=? #\A #\a))
 167
 168     (pass-if "char-ci>=? #\\A #\\B"
 169       (not (char-ci>=? #\A #\B)))
 170
 171     (pass-if "char-ci>=? #\\B #\\A"
 172       (char-ci>=? #\B #\A)))
 173
 174   (with-test-prefix "categories"
 175
 176     (pass-if "char-alphabetic?"
 177       (and (char-alphabetic? #\a)
 178            (char-alphabetic? #\A)
 179            (not (char-alphabetic? #\1))
 180            (not (char-alphabetic? #\+))))
 181
 182     (pass-if "char-numeric?"
 183       (and (not (char-numeric? #\a))
 184            (not (char-numeric? #\A))
 185            (char-numeric? #\1)
 186            (not (char-numeric? #\+))))
 187
 188     (pass-if "char-whitespace?"
 189       (and (not (char-whitespace? #\a))
 190            (not (char-whitespace? #\A))
 191            (not (char-whitespace? #\1))
 192            (char-whitespace? #\space)
 193            (not (char-whitespace? #\+))))
 194
 195     (pass-if "char-upper-case?"
 196       (and (not (char-upper-case? #\a))
 197            (char-upper-case? #\A)
 198            (not (char-upper-case? #\1))
 199            (not (char-upper-case? #\+))))
 200
 201     (pass-if "char-lower-case?"
 202       (and (char-lower-case? #\a)
 203            (not (char-lower-case? #\A))
 204            (not (char-lower-case? #\1))
 205            (not (char-lower-case? #\+))))
 206
 207     (pass-if "char-is-both? works"
 208       (and
 209        (not (char-is-both? #\?))
 210        (not (char-is-both? #\newline))
 211        (char-is-both? #\a)
 212        (char-is-both? #\Z)
 213        (not (char-is-both? #\1))))
 214
 215     (pass-if "char-general-category"
 216       (and (eq? (char-general-category #\a) 'Ll)
 217            (eq? (char-general-category #\A) 'Lu)
 218            (eq? (char-general-category #\762) 'Lt))))
 219
 220   (with-test-prefix "integer"
 221
 222     (pass-if "char->integer"
 223       (eqv? (char->integer #\A) 65))
 224
 225     (pass-if "integer->char"
 226       (eqv? (integer->char 65) #\A))
 227
 228     (pass-if-exception "integer->char out of range, -1" exception:out-of-range
 229       (integer->char -1))
 230
 231     (pass-if-exception "integer->char out of range, surrrogate"
 232                        exception:out-of-range
 233       (integer->char #xd800))
 234
 235     (pass-if-exception "integer->char out of range, too big"
 236                        exception:out-of-range
 237       (integer->char #x110000))
 238
 239     (pass-if-exception "octal out of range, surrrogate"
 240                        exception:out-of-range-octal
 241       (with-input-from-string "#\\154000" read))
 242
 243     (pass-if-exception "octal out of range, too big"
 244                        exception:out-of-range-octal
 245       (with-input-from-string "#\\4200000" read)))
 246
 247   (with-test-prefix "case"
 248
 249     (pass-if "char-upcase"
 250       (eqv? (char-upcase #\a) #\A))
 251
 252     (pass-if "char-downcase"
 253       (eqv? (char-downcase #\A) #\a))
 254
 255     (pass-if "char-titlecase"
 256       (and (eqv? (char-titlecase #\a) #\A)
 257            (eqv? (char-titlecase #\763) #\762))))
 258
 259   (with-test-prefix "charnames"
 260
 261     (pass-if "R5RS character names"
 262       (and (eqv? #\space (integer->char #x20))
 263            (eqv? #\newline (integer->char #x0A))))
 264
 265     (pass-if "R6RS character names"
 266       (and (eqv? #\nul (integer->char #x00))
 267            (eqv? #\alarm (integer->char #x07))
 268            (eqv? #\backspace (integer->char #x08))
 269            (eqv? #\tab (integer->char #x09))
 270            (eqv? #\linefeed (integer->char #x0A))
 271            (eqv? #\newline (integer->char #x0A))
 272            (eqv? #\vtab (integer->char #x0B))
 273            (eqv? #\page (integer->char #x0C))
 274            (eqv? #\return (integer->char #x0D))
 275            (eqv? #\esc (integer->char #x1B))
 276            (eqv? #\space (integer->char #x20))
 277            (eqv? #\delete (integer->char #x7F))))
 278
 279     (pass-if "R5RS character names are case insensitive"
 280       (and (eqv? #\space #\ )
 281            (eqv? #\SPACE #\ )
 282            (eqv? #\Space #\ )
 283            (eqv? #\newline (integer->char 10))
 284            (eqv? #\NEWLINE (integer->char 10))
 285            (eqv? #\Newline (integer->char 10))))
 286
 287     (pass-if "C0 control names are case insensitive"
 288       (and (eqv? #\nul #\000)
 289            (eqv? #\soh #\001)
 290            (eqv? #\stx #\002)
 291            (eqv? #\NUL #\000)
 292            (eqv? #\SOH #\001)
 293            (eqv? #\STX #\002)
 294            (eqv? #\Nul #\000)
 295            (eqv? #\Soh #\001)
 296            (eqv? #\Stx #\002)))
 297
 298     (pass-if "alt charnames are case insensitive"
 299       (eqv? #\null #\nul)
 300       (eqv? #\NULL #\nul)
 301       (eqv? #\Null #\nul))
 302
 303     (pass-if-exception "bad charname" exception:unknown-character-name
 304       (with-input-from-string "#\\blammo" read))
 305
 306     (pass-if "R5RS character names are preferred write format"
 307       (string=?
 308        (with-output-to-string (lambda () (write #\space)))
 309        "#\\space"))
 310
 311     (pass-if "C0 control character names are preferred write format"
 312       (string=?
 313        (with-output-to-string (lambda () (write #\soh)))
 314        "#\\soh"))
 315
 316     (pass-if "combining accent is pretty-printed"
 317       (let ((accent (integer->char #x030f))) ; COMBINING DOUBLE GRAVE ACCENT
 318         (string=?
 319          (with-output-to-string (lambda () (write accent)))
 320          "#\\◌̏")))
 321
 322     (pass-if "combining X is pretty-printed"
 323       (let ((x (integer->char #x0353))) ; COMBINING X BELOW
 324         (string=?
 325          (with-output-to-string (lambda () (write x)))
 326          "#\\◌͓")))))