test-suite/tests/chars.test

   1 ;;;; chars.test --- test suite for Guile's char functions    -*- scheme -*-
   2 ;;;; Greg J. Badros <gjb@cs.washington.edu>
   3 ;;;;
   4 ;;;;    Copyright (C) 2000, 2006, 2009 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 ;; Run THUNK in the context of the reader options OPTS
  33 (define (with-read-options opts thunk)
  34   (let ((saved-options (read-options)))
  35     (dynamic-wind
  36         (lambda ()
  37           (read-options opts))
  38         thunk
  39         (lambda ()
  40           (read-options saved-options)))))
  41
  42 (with-test-prefix "basic char handling"
  43
  44   (with-test-prefix "evaluator"
  45
  46     ;; The following test makes sure that the evaluator distinguishes between
  47     ;; evaluator-internal instruction codes and characters.
  48     (pass-if-exception "evaluating chars"
  49       exception:wrong-type-arg
  50       (eval '(#\0) (interaction-environment))))
  51
  52   (with-test-prefix "comparisons"
  53
  54     ;; char=?
  55     (pass-if "char=? #\\A #\\A"
  56       (char=? #\A #\A))
  57
  58     (expect-fail "char=? #\\A #\\a"
  59       (char=? #\A #\a))
  60
  61     (expect-fail "char=? #\\A #\\B"
  62       (char=? #\A #\B))
  63
  64     (expect-fail "char=? #\\B #\\A"
  65       (char=? #\A #\B))
  66
  67     ;; char<?
  68     (expect-fail "char<? #\\A #\\A"
  69       (char<? #\A #\A))
  70
  71     (pass-if "char<? #\\A #\\a"
  72       (char<? #\A #\a))
  73
  74     (pass-if "char<? #\\A #\\B"
  75       (char<? #\A #\B))
  76
  77     (expect-fail "char<? #\\B #\\A"
  78       (char<? #\B #\A))
  79
  80     ;; char<=?
  81     (pass-if "char<=? #\\A #\\A"
  82       (char<=? #\A #\A))
  83
  84     (pass-if "char<=? #\\A #\\a"
  85       (char<=? #\A #\a))
  86
  87     (pass-if "char<=? #\\A #\\B"
  88       (char<=? #\A #\B))
  89
  90     (expect-fail "char<=? #\\B #\\A"
  91       (char<=? #\B #\A))
  92
  93     ;; char>?
  94     (expect-fail "char>? #\\A #\\A"
  95       (char>? #\A #\A))
  96
  97     (expect-fail "char>? #\\A #\\a"
  98       (char>? #\A #\a))
  99
 100     (expect-fail "char>? #\\A #\\B"
 101       (char>? #\A #\B))
 102
 103     (pass-if "char>? #\\B #\\A"
 104       (char>? #\B #\A))
 105
 106     ;; char>=?
 107     (pass-if "char>=? #\\A #\\A"
 108       (char>=? #\A #\A))
 109
 110     (expect-fail "char>=? #\\A #\\a"
 111       (char>=? #\A #\a))
 112
 113     (expect-fail "char>=? #\\A #\\B"
 114       (char>=? #\A #\B))
 115
 116     (pass-if "char>=? #\\B #\\A"
 117       (char>=? #\B #\A))
 118
 119     ;; char-ci=?
 120     (pass-if "char-ci=? #\\A #\\A"
 121       (char-ci=? #\A #\A))
 122
 123     (pass-if "char-ci=? #\\A #\\a"
 124       (char-ci=? #\A #\a))
 125
 126     (expect-fail "char-ci=? #\\A #\\B"
 127       (char-ci=? #\A #\B))
 128
 129     (expect-fail "char-ci=? #\\B #\\A"
 130       (char-ci=? #\A #\B))
 131
 132     ;; char-ci<?
 133     (expect-fail "char-ci<? #\\A #\\A"
 134       (char-ci<? #\A #\A))
 135
 136     (expect-fail "char-ci<? #\\A #\\a"
 137       (char-ci<? #\A #\a))
 138
 139     (pass-if "char-ci<? #\\A #\\B"
 140       (char-ci<? #\A #\B))
 141
 142     (expect-fail "char-ci<? #\\B #\\A"
 143       (char-ci<? #\B #\A))
 144
 145     ;; char-ci<=?
 146     (pass-if "char-ci<=? #\\A #\\A"
 147       (char-ci<=? #\A #\A))
 148
 149     (pass-if "char-ci<=? #\\A #\\a"
 150       (char-ci<=? #\A #\a))
 151
 152     (pass-if "char-ci<=? #\\A #\\B"
 153       (char-ci<=? #\A #\B))
 154
 155     (expect-fail "char-ci<=? #\\B #\\A"
 156       (char-ci<=? #\B #\A))
 157
 158     ;; char-ci>?
 159     (expect-fail "char-ci>? #\\A #\\A"
 160       (char-ci>? #\A #\A))
 161
 162     (expect-fail "char-ci>? #\\A #\\a"
 163       (char-ci>? #\A #\a))
 164
 165     (expect-fail "char-ci>? #\\A #\\B"
 166       (char-ci>? #\A #\B))
 167
 168     (pass-if "char-ci>? #\\B #\\A"
 169       (char-ci>? #\B #\A))
 170
 171     ;; char-ci>=?
 172     (pass-if "char-ci>=? #\\A #\\A"
 173       (char-ci>=? #\A #\A))
 174
 175     (pass-if "char-ci>=? #\\A #\\a"
 176       (char-ci>=? #\A #\a))
 177
 178     (expect-fail "char-ci>=? #\\A #\\B"
 179       (char-ci>=? #\A #\B))
 180
 181     (pass-if "char-ci>=? #\\B #\\A"
 182       (char-ci>=? #\B #\A)))
 183
 184   (with-test-prefix "categories"
 185
 186     (pass-if "char-alphabetic?"
 187       (and (char-alphabetic? #\a)
 188            (char-alphabetic? #\A)
 189            (not (char-alphabetic? #\1))
 190            (not (char-alphabetic? #\+))))
 191
 192     (pass-if "char-numeric?"
 193       (and (not (char-numeric? #\a))
 194            (not (char-numeric? #\A))
 195            (char-numeric? #\1)
 196            (not (char-numeric? #\+))))
 197
 198     (pass-if "char-whitespace?"
 199       (and (not (char-whitespace? #\a))
 200            (not (char-whitespace? #\A))
 201            (not (char-whitespace? #\1))
 202            (char-whitespace? #\space)
 203            (not (char-whitespace? #\+))))
 204
 205     (pass-if "char-upper-case?"
 206       (and (not (char-upper-case? #\a))
 207            (char-upper-case? #\A)
 208            (not (char-upper-case? #\1))
 209            (not (char-upper-case? #\+))))
 210
 211     (pass-if "char-lower-case?"
 212       (and (char-lower-case? #\a)
 213            (not (char-lower-case? #\A))
 214            (not (char-lower-case? #\1))
 215            (not (char-lower-case? #\+))))
 216
 217     (pass-if "char-is-both? works"
 218       (and
 219        (not (char-is-both? #\?))
 220        (not (char-is-both? #\newline))
 221        (char-is-both? #\a)
 222        (char-is-both? #\Z)
 223        (not (char-is-both? #\1))))
 224
 225     (pass-if "char-general-category"
 226       (and (eq? (char-general-category #\a) 'Ll)
 227            (eq? (char-general-category #\A) 'Lu)
 228            (eq? (char-general-category #\762) 'Lt))))
 229
 230   (with-test-prefix "integer"
 231
 232     (pass-if "char->integer"
 233       (eqv? (char->integer #\A) 65))
 234
 235     (pass-if "integer->char"
 236       (eqv? (integer->char 65) #\A))
 237
 238     (pass-if-exception "integer->char out of range, -1" exception:out-of-range
 239       (integer->char -1))
 240
 241     (pass-if-exception "integer->char out of range, surrrogate"
 242                        exception:out-of-range
 243       (integer->char #xd800))
 244
 245     (pass-if-exception "integer->char out of range, too big"
 246                        exception:out-of-range
 247       (integer->char #x110000))
 248
 249     (pass-if-exception "octal out of range, surrrogate"
 250                        exception:out-of-range-octal
 251       (with-input-from-string "#\\154000" read))
 252
 253     (pass-if-exception "octal out of range, too big"
 254                        exception:out-of-range-octal
 255       (with-input-from-string "#\\4200000" read)))
 256
 257   (with-test-prefix "case"
 258
 259     (pass-if "char-upcase"
 260       (eqv? (char-upcase #\a) #\A))
 261
 262     (pass-if "char-downcase"
 263       (eqv? (char-downcase #\A) #\a))
 264
 265     (pass-if "char-titlecase"
 266       (and (eqv? (char-titlecase #\a) #\A)
 267            (eqv? (char-titlecase #\763) #\762))))
 268
 269   (with-test-prefix "charnames"
 270
 271     (pass-if "R5RS character names"
 272       (and (eqv? #\space (integer->char #x20))
 273            (eqv? #\newline (integer->char #x0A))))
 274
 275     (pass-if "R6RS character names"
 276       (and (eqv? #\nul (integer->char #x00))
 277            (eqv? #\alarm (integer->char #x07))
 278            (eqv? #\backspace (integer->char #x08))
 279            (eqv? #\tab (integer->char #x09))
 280            (eqv? #\linefeed (integer->char #x0A))
 281            (eqv? #\newline (integer->char #x0A))
 282            (eqv? #\vtab (integer->char #x0B))
 283            (eqv? #\page (integer->char #x0C))
 284            (eqv? #\return (integer->char #x0D))
 285            (eqv? #\esc (integer->char #x1B))
 286            (eqv? #\space (integer->char #x20))
 287            (eqv? #\delete (integer->char #x7F))))
 288
 289     (pass-if "R5RS character names are case insensitive"
 290       (and (eqv? #\space #\ )
 291            (eqv? #\SPACE #\ )
 292            (eqv? #\Space #\ )
 293            (eqv? #\newline (integer->char 10))
 294            (eqv? #\NEWLINE (integer->char 10))
 295            (eqv? #\Newline (integer->char 10))))
 296
 297     (pass-if "C0 control names are case insensitive"
 298       (and (eqv? #\nul #\000)
 299            (eqv? #\soh #\001)
 300            (eqv? #\stx #\002)
 301            (eqv? #\NUL #\000)
 302            (eqv? #\SOH #\001)
 303            (eqv? #\STX #\002)
 304            (eqv? #\Nul #\000)
 305            (eqv? #\Soh #\001)
 306            (eqv? #\Stx #\002)))
 307
 308     (pass-if "alt charnames are case insensitive"
 309       (eqv? #\null #\nul)
 310       (eqv? #\NULL #\nul)
 311       (eqv? #\Null #\nul))
 312
 313     (pass-if-exception "bad charname" exception:unknown-character-name
 314       (with-input-from-string "#\\blammo" read))
 315
 316     (pass-if "R5RS character names are preferred write format"
 317       (string=?
 318        (with-output-to-string (lambda () (write #\space)))
 319        "#\\space"))
 320
 321     (pass-if "C0 control character names are preferred write format"
 322       (string=?
 323        (with-output-to-string (lambda () (write #\soh)))
 324        "#\\soh"))))
 325
 326 (with-test-prefix "R6RS hex escapes"
 327
 328   (pass-if "one-digit hex escape"
 329     (eqv? (with-read-options '(r6rs-hex-escapes)
 330             (lambda ()
 331               (with-input-from-string "#\\xA" read)))
 332           (integer->char #x0A)))
 333
 334   (pass-if "two-digit hex escape"
 335     (eqv? (with-read-options '(r6rs-hex-escapes)
 336             (lambda ()
 337               (with-input-from-string "#\\xFF" read)))
 338           (integer->char #xFF)))
 339
 340   (pass-if "four-digit hex escape"
 341     (eqv? (with-read-options '(r6rs-hex-escapes)
 342             (lambda ()
 343               (with-input-from-string "#\\x00FF" read)))
 344           (integer->char #xFF)))
 345
 346   (pass-if "eight-digit hex escape"
 347     (eqv? (with-read-options '(r6rs-hex-escapes)
 348             (lambda ()
 349               (with-input-from-string "#\\x00006587" read)))
 350           (integer->char #x6587)))
 351   (pass-if "write R6RS escapes"
 352     (string=?
 353      (with-read-options '(r6rs-hex-escapes)
 354        (lambda ()
 355          (with-output-to-string
 356            (lambda ()
 357              (write (integer->char #x80))))))
 358      "#\\x80")))
 359