test-suite/tests/srfi-14.test

   1 ;;;; srfi-14.test          -*- mode:scheme; coding: iso-8859-1 -*-
   2 ;;;; --- Test suite for Guile's SRFI-14 functions.
   3 ;;;; Martin Grabmueller, 2001-07-16
   4 ;;;;
   5 ;;;; Copyright (C) 2001, 2006, 2009, 2010, 2014 Free Software Foundation, Inc.
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-srfi-14)
  22   :use-module (srfi srfi-14)
  23   :use-module (srfi srfi-1) ;; `every'
  24   :use-module (test-suite lib))
  25
  26
  27 (define exception:invalid-char-set-cursor
  28   (cons 'misc-error "^invalid character set cursor"))
  29
  30 (define exception:non-char-return
  31   (cons 'misc-error "returned non-char"))
  32
  33
  34 (with-test-prefix "char set contents"
  35
  36   (pass-if "empty set"
  37     (list= eqv?
  38            (char-set->list (char-set))
  39            '()))
  40
  41   (pass-if "single char"
  42     (list= eqv?
  43            (char-set->list (char-set #\a))
  44            (list #\a)))
  45
  46   (pass-if "contiguous chars"
  47     (list= eqv?
  48            (char-set->list (char-set #\a #\b #\c))
  49            (list #\a #\b #\c)))
  50
  51   (pass-if "discontiguous chars"
  52     (list= eqv?
  53            (char-set->list (char-set #\a #\c #\e))
  54            (list #\a #\c #\e))))
  55
  56 (with-test-prefix "char set additition"
  57
  58   (pass-if "empty + x"
  59     (let ((cs (char-set)))
  60       (char-set-adjoin! cs #\x)
  61       (list= eqv?
  62              (char-set->list cs)
  63              (list #\x))))
  64
  65   (pass-if "x + y"
  66     (let ((cs (char-set #\x)))
  67       (char-set-adjoin! cs #\y)
  68       (list= eqv?
  69              (char-set->list cs)
  70              (list #\x #\y))))
  71
  72   (pass-if "x + w"
  73     (let ((cs (char-set #\x)))
  74       (char-set-adjoin! cs #\w)
  75       (list= eqv?
  76              (char-set->list cs)
  77              (list #\w #\x))))
  78
  79   (pass-if "x + z"
  80     (let ((cs (char-set #\x)))
  81       (char-set-adjoin! cs #\z)
  82       (list= eqv?
  83              (char-set->list cs)
  84              (list #\x #\z))))
  85
  86   (pass-if "x + v"
  87     (let ((cs (char-set #\x)))
  88       (char-set-adjoin! cs #\v)
  89       (list= eqv?
  90              (char-set->list cs)
  91              (list #\v #\x))))
  92
  93   (pass-if "uv + w"
  94     (let ((cs (char-set #\u #\v)))
  95       (char-set-adjoin! cs #\w)
  96       (list= eqv?
  97              (char-set->list cs)
  98              (list #\u #\v #\w))))
  99
 100   (pass-if "uv + t"
 101     (let ((cs (char-set #\u #\v)))
 102       (char-set-adjoin! cs #\t)
 103       (list= eqv?
 104              (char-set->list cs)
 105              (list #\t #\u #\v))))
 106
 107   (pass-if "uv + x"
 108     (let ((cs (char-set #\u #\v)))
 109       (char-set-adjoin! cs #\x)
 110       (list= eqv?
 111              (char-set->list cs)
 112              (list #\u #\v #\x))))
 113
 114   (pass-if "uv + s"
 115     (let ((cs (char-set #\u #\v)))
 116       (char-set-adjoin! cs #\s)
 117       (list= eqv?
 118              (char-set->list cs)
 119              (list #\s #\u #\v))))
 120
 121   (pass-if "uvx + w"
 122     (let ((cs (char-set #\u #\v #\x)))
 123       (char-set-adjoin! cs #\w)
 124       (list= eqv?
 125              (char-set->list cs)
 126              (list #\u #\v #\w #\x))))
 127
 128   (pass-if "uvx + y"
 129     (let ((cs (char-set #\u #\v #\x)))
 130       (char-set-adjoin! cs #\y)
 131       (list= eqv?
 132              (char-set->list cs)
 133              (list #\u #\v #\x #\y))))
 134
 135   (pass-if "uvxy + w"
 136     (let ((cs (char-set #\u #\v #\x #\y)))
 137       (char-set-adjoin! cs #\w)
 138       (list= eqv?
 139              (char-set->list cs)
 140              (list #\u #\v #\w #\x #\y)))))
 141
 142 (with-test-prefix "char set union"
 143   (pass-if "null U abc"
 144     (char-set= (char-set-union (char-set) (->char-set "abc"))
 145                (->char-set "abc")))
 146
 147   (pass-if "ab U ab"
 148     (char-set= (char-set-union (->char-set "ab") (->char-set "ab"))
 149                (->char-set "ab")))
 150
 151   (pass-if "ab U bc"
 152     (char-set= (char-set-union (->char-set "ab") (->char-set "bc"))
 153                (->char-set "abc")))
 154
 155   (pass-if "ab U cd"
 156     (char-set= (char-set-union (->char-set "ab") (->char-set "cd"))
 157                (->char-set "abcd")))
 158
 159   (pass-if "ab U de"
 160     (char-set= (char-set-union (->char-set "ab") (->char-set "de"))
 161                (->char-set "abde")))
 162
 163   (pass-if "abc U bcd"
 164     (char-set= (char-set-union (->char-set "abc") (->char-set "bcd"))
 165                (->char-set "abcd")))
 166
 167   (pass-if "abdf U abcdefg"
 168     (char-set= (char-set-union (->char-set "abdf") (->char-set "abcdefg"))
 169                (->char-set "abcdefg")))
 170
 171   (pass-if "abef U cd"
 172     (char-set= (char-set-union (->char-set "abef") (->char-set "cd"))
 173                (->char-set "abcdef")))
 174
 175   (pass-if "abgh U cd"
 176     (char-set= (char-set-union (->char-set "abgh") (->char-set "cd"))
 177                (->char-set "abcdgh")))
 178
 179   (pass-if "bc U ab"
 180     (char-set= (char-set-union (->char-set "bc") (->char-set "ab"))
 181                (->char-set "abc")))
 182
 183   (pass-if "cd U ab"
 184     (char-set= (char-set-union (->char-set "cd") (->char-set "ab"))
 185                (->char-set "abcd")))
 186
 187   (pass-if "de U ab"
 188     (char-set= (char-set-union (->char-set "de") (->char-set "ab"))
 189                (->char-set "abde")))
 190
 191   (pass-if "cd U abc"
 192     (char-set= (char-set-union (->char-set "cd") (->char-set "abc"))
 193                (->char-set "abcd")))
 194
 195   (pass-if "cd U abcd"
 196     (char-set= (char-set-union (->char-set "cd") (->char-set "abcd"))
 197                (->char-set "abcd")))
 198
 199   (pass-if "cde U abcdef"
 200     (char-set= (char-set-union (->char-set "cde") (->char-set "abcdef"))
 201                (->char-set "abcdef"))))
 202
 203 (with-test-prefix "char set xor"
 204   (pass-if "null - xy"
 205     (char-set= (char-set-xor (char-set) (char-set #\x #\y))
 206                (char-set #\x #\y)))
 207
 208   (pass-if "x - x"
 209     (char-set= (char-set-xor (char-set #\x) (char-set #\x))
 210                (char-set)))
 211
 212   (pass-if "xy - x"
 213     (char-set= (char-set-xor (char-set #\x #\y) (char-set #\x))
 214                (char-set #\y)))
 215
 216   (pass-if "xy - y"
 217     (char-set= (char-set-xor (char-set #\x #\y) (char-set #\y))
 218                (char-set #\x)))
 219
 220   (pass-if "wxy - w"
 221     (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\w))
 222                (char-set #\x #\y)))
 223
 224   (pass-if "wxy - x"
 225     (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\x))
 226                (char-set #\w #\y)))
 227
 228   (pass-if "wxy - y"
 229     (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\y))
 230                (char-set #\w #\x)))
 231
 232   (pass-if "uvxy - u"
 233     (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\u))
 234                (char-set #\v #\x #\y)))
 235
 236   (pass-if "uvxy - v"
 237     (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\v))
 238                (char-set #\u #\x #\y)))
 239
 240   (pass-if "uvxy - x"
 241     (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\x))
 242                (char-set #\u #\v #\y)))
 243
 244   (pass-if "uvxy - y"
 245     (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\y))
 246                (char-set #\u #\v #\x)))
 247
 248   (pass-if "uwy - u"
 249     (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\u))
 250                (char-set #\w #\y)))
 251
 252   (pass-if "uwy - w"
 253     (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\w))
 254                (char-set #\u #\y)))
 255
 256   (pass-if "uwy - y"
 257     (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\y))
 258                (char-set #\u #\w)))
 259
 260   (pass-if "uvwy - v"
 261     (char-set= (char-set-xor (char-set #\u #\v #\w #\y) (char-set #\v))
 262                (char-set #\u #\w #\y))))
 263
 264
 265 (with-test-prefix "char-set?"
 266
 267   (pass-if "success on empty set"
 268     (char-set? (char-set)))
 269
 270   (pass-if "success on non-empty set"
 271     (char-set? char-set:printing))
 272
 273   (pass-if "failure on empty set"
 274     (not (char-set? #t))))
 275
 276
 277 (with-test-prefix "char-set="
 278   (pass-if "success, no arg"
 279     (char-set=))
 280
 281   (pass-if "success, one arg"
 282     (char-set= char-set:lower-case))
 283
 284   (pass-if "success, two args"
 285     (char-set= char-set:upper-case char-set:upper-case))
 286
 287   (pass-if "failure, first empty"
 288     (not (char-set= (char-set) (char-set #\a))))
 289
 290   (pass-if "failure, second empty"
 291     (not (char-set= (char-set #\a) (char-set))))
 292
 293   (pass-if "success, more args"
 294     (char-set= char-set:blank char-set:blank char-set:blank))
 295
 296   (pass-if "failure, same length, different elements"
 297     (not (char-set= (char-set #\a #\b #\d) (char-set #\a #\c #\d)))))
 298
 299 (with-test-prefix "char-set<="
 300   (pass-if "success, no arg"
 301     (char-set<=))
 302
 303   (pass-if "success, one arg"
 304     (char-set<= char-set:lower-case))
 305
 306   (pass-if "success, two args"
 307     (char-set<= char-set:upper-case char-set:upper-case))
 308
 309   (pass-if "success, first empty"
 310     (char-set<= (char-set) (char-set #\a)))
 311
 312   (pass-if "failure, second empty"
 313     (not (char-set<= (char-set #\a) (char-set))))
 314
 315   (pass-if "success, more args, equal"
 316     (char-set<= char-set:blank char-set:blank char-set:blank))
 317
 318   (pass-if "success, more args, not equal"
 319     (char-set<= char-set:blank
 320                 (char-set-adjoin char-set:blank #\F)
 321                 (char-set-adjoin char-set:blank #\F #\o))))
 322
 323 (with-test-prefix "char-set-hash"
 324    (pass-if "empty set, bound"
 325       (let ((h (char-set-hash char-set:empty 31)))
 326         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 327
 328    (pass-if "empty set, no bound"
 329       (let ((h (char-set-hash char-set:empty)))
 330         (and h (number? h) (exact? h) (>= h 0))))
 331
 332    (pass-if "full set, bound"
 333       (let ((h (char-set-hash char-set:full 31)))
 334         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 335
 336    (pass-if "full set, no bound"
 337       (let ((h (char-set-hash char-set:full)))
 338         (and h (number? h) (exact? h) (>= h 0))))
 339
 340    (pass-if "other set, bound"
 341       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
 342         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 343
 344    (pass-if "other set, no bound"
 345       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
 346         (and h (number? h) (exact? h) (>= h 0)))))
 347
 348
 349 (with-test-prefix "char-set cursor"
 350
 351   (pass-if-exception "invalid character cursor"
 352      exception:wrong-type-arg
 353      (let* ((cs (char-set #\B #\r #\a #\z))
 354             (cc (char-set-cursor cs)))
 355        (char-set-ref cs 1000)))
 356
 357   (pass-if "success"
 358      (let* ((cs (char-set #\B #\r #\a #\z))
 359             (cc (char-set-cursor cs)))
 360        (char? (char-set-ref cs cc))))
 361
 362   (pass-if "end of set fails"
 363      (let* ((cs (char-set #\a))
 364             (cc (char-set-cursor cs)))
 365        (not (end-of-char-set? cc))))
 366
 367   (pass-if "end of set succeeds, empty set"
 368      (let* ((cs (char-set))
 369             (cc (char-set-cursor cs)))
 370        (end-of-char-set? cc)))
 371
 372   (pass-if "end of set succeeds, non-empty set"
 373      (let* ((cs (char-set #\a))
 374             (cc (char-set-cursor cs))
 375             (cc (char-set-cursor-next cs cc)))
 376        (end-of-char-set? cc))))
 377
 378 (with-test-prefix "char-set-fold"
 379
 380   (pass-if "count members"
 381      (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
 382
 383   (pass-if "copy set"
 384      (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
 385                                       (char-set) (char-set #\a #\b))) 2)))
 386
 387 (define char-set:256
 388   (string->char-set (apply string (map integer->char (iota 256)))))
 389
 390 (with-test-prefix "char-set-unfold"
 391
 392   (pass-if "create char set"
 393      (char-set= char-set:256
 394                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 395                                  (lambda (s) (+ s 1)) 0)))
 396   (pass-if "create char set (base set)"
 397      (char-set= char-set:256
 398                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 399                                  (lambda (s) (+ s 1)) 0 char-set:empty))))
 400
 401 (with-test-prefix "char-set-unfold!"
 402
 403   (pass-if "create char set"
 404      (char-set= char-set:256
 405                 (char-set-unfold! (lambda (s) (= s 256)) integer->char
 406                                  (lambda (s) (+ s 1)) 0
 407                                  (char-set-copy char-set:empty))))
 408
 409   (pass-if "create char set"
 410      (char-set= char-set:256
 411                 (char-set-unfold! (lambda (s) (= s 32)) integer->char
 412                                  (lambda (s) (+ s 1)) 0
 413                                  (char-set-copy char-set:256)))))
 414
 415
 416 (with-test-prefix "char-set-for-each"
 417
 418   (pass-if "copy char set"
 419      (= (char-set-size (let ((cs (char-set)))
 420                          (char-set-for-each
 421                           (lambda (c) (char-set-adjoin! cs c))
 422                           (char-set #\a #\b))
 423                          cs))
 424         2)))
 425
 426 (with-test-prefix "char-set-map"
 427
 428   (pass-if "upper case char set 1"
 429      (char-set= (char-set-map char-upcase
 430                               (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 431                 (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
 432
 433   (pass-if "upper case char set 2"
 434      (char-set= (char-set-map char-upcase
 435                               (string->char-set "àáâãäåæçèéêëìíîïñòóôõöøùúûüýþ"))
 436                 (string->char-set "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝÞ"))))
 437
 438 (with-test-prefix "string->char-set"
 439
 440   (pass-if "some char set"
 441      (let ((chars '(#\g #\u #\i #\l #\e)))
 442        (char-set= (list->char-set chars)
 443                   (string->char-set (apply string chars))))))
 444
 445 (with-test-prefix "char-set->string"
 446
 447   (pass-if "some char set"
 448      (let ((cs (char-set #\g #\u #\i #\l #\e)))
 449        (string=? (char-set->string cs)
 450                  "egilu"))))
 451
 452 (with-test-prefix "list->char-set"
 453
 454   (pass-if "list->char-set"
 455     (char-set= (list->char-set '(#\a #\b #\c))
 456                (->char-set "abc")))
 457
 458   (pass-if "list->char-set!"
 459     (let* ((cs (char-set #\a #\z)))
 460       (list->char-set! '(#\m #\n) cs)
 461       (char-set= cs
 462                  (char-set #\a #\m #\n #\z)))))
 463
 464 (with-test-prefix "string->char-set"
 465
 466   (pass-if "string->char-set"
 467     (char-set= (string->char-set "foobar")
 468                (string->char-set "barfoo")))
 469
 470   (pass-if "string->char-set cs"
 471     (char-set= (string->char-set "foo" (string->char-set "bar"))
 472                (string->char-set "barfoo")))
 473
 474   (pass-if "string->char-set!"
 475     (let ((cs (string->char-set "bar")))
 476       (string->char-set! "foo" cs)
 477       (char-set= cs
 478                  (string->char-set "barfoo")))))
 479
 480 (with-test-prefix "char-set-filter"
 481
 482   (pass-if "filter w/o base"
 483     (char-set=
 484      (char-set-filter (lambda (c) (char=? c #\x))
 485                       (->char-set "qrstuvwxyz"))
 486      (->char-set #\x)))
 487
 488   (pass-if "filter w/ base"
 489     (char-set=
 490      (char-set-filter (lambda (c) (char=? c #\x))
 491                       (->char-set "qrstuvwxyz")
 492                       (->char-set "op"))
 493
 494      (->char-set "opx")))
 495
 496   (pass-if "filter!"
 497     (let ((cs (->char-set "abc")))
 498       (set! cs (char-set-filter! (lambda (c) (char=? c #\x))
 499                                  (->char-set "qrstuvwxyz")
 500                                  cs))
 501       (char-set= (string->char-set "abcx")
 502                  cs))))
 503
 504
 505 (with-test-prefix "char-set-intersection"
 506
 507   (pass-if "empty"
 508     (char-set= (char-set-intersection (char-set) (char-set))
 509                (char-set)))
 510
 511   (pass-if "identical, one element"
 512     (char-set= (char-set-intersection (char-set #\a) (char-set #\a))
 513                (char-set #\a)))
 514
 515   (pass-if "identical, two elements"
 516     (char-set= (char-set-intersection (char-set #\a #\b) (char-set #\a #\b))
 517                (char-set #\a #\b)))
 518
 519   (pass-if "identical, two elements"
 520     (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\a #\c))
 521                (char-set #\a #\c)))
 522
 523   (pass-if "one vs null"
 524     (char-set= (char-set-intersection (char-set #\a) (char-set))
 525                (char-set)))
 526
 527   (pass-if "null vs one"
 528     (char-set= (char-set-intersection (char-set) (char-set #\a))
 529                (char-set)))
 530
 531   (pass-if "no elements shared"
 532     (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\b #\d))
 533                (char-set)))
 534
 535   (pass-if "one elements shared"
 536     (char-set= (char-set-intersection (char-set #\a #\c #\d) (char-set #\b #\d))
 537                (char-set #\d))))
 538
 539 (with-test-prefix "char-set-complement"
 540
 541   (pass-if "complement of null"
 542            (char-set= (char-set-complement (char-set))
 543                       (char-set-union (ucs-range->char-set 0 #xd800)
 544                                       (ucs-range->char-set #xe000 #x110000))))
 545
 546   (pass-if "complement of null (2)"
 547            (char-set= (char-set-complement (char-set))
 548                       (ucs-range->char-set 0 #x110000)))
 549
 550   (pass-if "complement of #\\0"
 551            (char-set= (char-set-complement (char-set #\nul))
 552                       (ucs-range->char-set 1 #x110000)))
 553
 554   (pass-if "complement of U+10FFFF"
 555            (char-set= (char-set-complement (char-set (integer->char #x10ffff)))
 556                       (ucs-range->char-set 0 #x10ffff)))
 557
 558   (pass-if "complement of 'FOO'"
 559            (char-set= (char-set-complement (->char-set "FOO"))
 560                       (char-set-union (ucs-range->char-set 0 (char->integer #\F))
 561                                       (ucs-range->char-set (char->integer #\G)
 562                                                            (char->integer #\O))
 563                                       (ucs-range->char-set (char->integer #\P)
 564                                                             #x110000))))
 565   (pass-if "complement of #\\a #\\b U+010300"
 566            (char-set= (char-set-complement (char-set #\a #\b (integer->char #x010300)))
 567                       (char-set-union (ucs-range->char-set 0 (char->integer #\a))
 568                                       (ucs-range->char-set (char->integer #\c) #x010300)
 569                                       (ucs-range->char-set #x010301 #x110000)))))
 570
 571 (with-test-prefix "ucs-range->char-set"
 572   (pass-if "char-set"
 573     (char-set= (ucs-range->char-set 65 68)
 574                (->char-set "ABC")))
 575
 576   (pass-if "char-set w/ base"
 577     (char-set= (ucs-range->char-set 65 68 #f (->char-set "DEF"))
 578                (->char-set "ABCDEF")))
 579
 580   (pass-if "char-set!"
 581     (let ((cs (->char-set "DEF")))
 582       (ucs-range->char-set! 65 68 #f cs)
 583       (char-set= cs
 584                  (->char-set "ABCDEF")))))
 585
 586 (with-test-prefix "char-set-count"
 587   (pass-if "null"
 588     (= 0 (char-set-count (lambda (c) #t) (char-set))))
 589
 590   (pass-if "count"
 591     (= 5 (char-set-count (lambda (c) #t)
 592                          (->char-set "guile")))))
 593
 594 (with-test-prefix "char-set-contains?"
 595   (pass-if "#\\a not in null"
 596     (not (char-set-contains? (char-set) #\a)))
 597
 598   (pass-if "#\\a is in 'abc'"
 599     (char-set-contains? (->char-set "abc") #\a)))
 600
 601 (with-test-prefix "any / every"
 602   (pass-if "char-set-every #t"
 603     (char-set-every (lambda (c) #t)
 604                     (->char-set "abc")))
 605
 606   (pass-if "char-set-every #f"
 607     (not (char-set-every (lambda (c) (char=? c #\c))
 608                          (->char-set "abc"))))
 609
 610   (pass-if "char-set-any #t"
 611     (char-set-any (lambda (c) (char=? c #\c))
 612                   (->char-set "abc")))
 613
 614   (pass-if "char-set-any #f"
 615     (not (char-set-any (lambda (c) #f)
 616                        (->char-set "abc")))))
 617
 618 (with-test-prefix "char-set-delete"
 619   (pass-if "abc - a"
 620     (char-set= (char-set-delete (->char-set "abc") #\a)
 621                (char-set #\b #\c)))
 622
 623   (pass-if "abc - d"
 624     (char-set= (char-set-delete (->char-set "abc") #\d)
 625                (char-set #\a #\b #\c)))
 626
 627   (pass-if "delete! abc - a"
 628     (let ((cs (char-set #\a #\b #\c)))
 629       (char-set-delete! cs #\a)
 630       (char-set= cs (char-set #\b #\c)))))
 631
 632 (with-test-prefix "char-set-difference"
 633   (pass-if "not different"
 634     (char-set= (char-set-difference (->char-set "foobar") (->char-set "foobar"))
 635                (char-set)))
 636
 637   (pass-if "completely different"
 638     (char-set= (char-set-difference (->char-set "foo") (->char-set "bar"))
 639                (->char-set "foo")))
 640
 641   (pass-if "partially different"
 642     (char-set= (char-set-difference (->char-set "breakfast") (->char-set "breakroom"))
 643                (->char-set "fst"))))
 644
 645 (with-test-prefix "standard char sets (ASCII)"
 646
 647   (pass-if "char-set:lower-case"
 648      (char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz")
 649                  char-set:lower-case))
 650
 651   (pass-if "char-set:upper-case"
 652      (char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 653                  char-set:upper-case))
 654
 655   (pass-if "char-set:title-case"
 656      (char-set<= (string->char-set "")
 657                  char-set:title-case))
 658
 659   (pass-if "char-set:letter"
 660      (char-set<= (char-set-union
 661                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 662                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
 663                  char-set:letter))
 664
 665   (pass-if "char-set:digit"
 666      (char-set<= (string->char-set "0123456789")
 667                  char-set:digit))
 668
 669   (pass-if "char-set:hex-digit"
 670      (char-set<= (string->char-set "0123456789abcdefABCDEF")
 671                  char-set:hex-digit))
 672
 673   (pass-if "char-set:letter+digit"
 674      (char-set<= (char-set-union
 675                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 676                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 677                   (string->char-set "0123456789"))
 678                  char-set:letter+digit))
 679
 680   (pass-if "char-set:punctuation"
 681      (char-set<= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 682                  char-set:punctuation))
 683
 684   (pass-if "char-set:symbol"
 685      (char-set<= (string->char-set "$+<=>^`|~")
 686                  char-set:symbol))
 687
 688   (pass-if "char-set:graphic"
 689      (char-set<= (char-set-union
 690                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 691                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 692                   (string->char-set "0123456789")
 693                   (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 694                   (string->char-set "$+<=>^`|~"))
 695                  char-set:graphic))
 696
 697   (pass-if "char-set:whitespace"
 698      (char-set<= (string->char-set
 699                   (string
 700                    (integer->char #x09)
 701                    (integer->char #x0a)
 702                    (integer->char #x0b)
 703                    (integer->char #x0c)
 704                    (integer->char #x0d)
 705                    (integer->char #x20)))
 706                  char-set:whitespace))
 707
 708   (pass-if "char-set:printing"
 709      (char-set<= (char-set-union
 710                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 711                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 712                   (string->char-set "0123456789")
 713                   (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 714                   (string->char-set "$+<=>^`|~")
 715                   (string->char-set (string
 716                                      (integer->char #x09)
 717                                      (integer->char #x0a)
 718                                      (integer->char #x0b)
 719                                      (integer->char #x0c)
 720                                      (integer->char #x0d)
 721                                      (integer->char #x20))))
 722                  char-set:printing))
 723
 724   (pass-if "char-set:ASCII"
 725      (char-set= (ucs-range->char-set 0 128)
 726                 char-set:ascii))
 727
 728   (pass-if "char-set:iso-control"
 729      (char-set<= (string->char-set
 730                   (apply string
 731                          (map integer->char (append
 732                                              ;; U+0000 to U+001F
 733                                              (iota #x20)
 734                                              (list #x7f)))))
 735                  char-set:iso-control)))
 736
 737 \f
 738 ;;;
 739 ;;; Non-ASCII codepoints
 740 ;;;
 741 ;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
 742 ;;; SRFI-14 for implementations supporting this charset is well-defined.
 743 ;;;
 744
 745 (define (every? pred lst)
 746   (not (not (every pred lst))))
 747
 748 (when (defined? 'setlocale)
 749   (setlocale LC_ALL ""))
 750
 751 (with-test-prefix "Latin-1 (8-bit charset)"
 752
 753   (pass-if "char-set:lower-case"
 754     (char-set<= (string->char-set
 755                  (string-append "abcdefghijklmnopqrstuvwxyz"
 756                                 "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")
 757                  char-set:lower-case)))
 758
 759   (pass-if "char-set:upper-case"
 760     (char-set<= (string->char-set
 761                  (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 762                                 "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ")
 763                  char-set:lower-case)))
 764
 765   (pass-if "char-set:title-case"
 766     (char-set<= (string->char-set "")
 767                 char-set:title-case))
 768
 769   (pass-if "char-set:letter"
 770     (char-set<= (string->char-set
 771                  (string-append
 772                   ;; Lowercase
 773                   "abcdefghijklmnopqrstuvwxyz"
 774                   "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"
 775                   ;; Uppercase
 776                   "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 777                   "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
 778                   ;; Uncased
 779                   "ªº"))
 780                 char-set:letter))
 781
 782   (pass-if "char-set:digit"
 783     (char-set<= (string->char-set "0123456789")
 784                 char-set:digit))
 785
 786   (pass-if "char-set:hex-digit"
 787     (char-set<= (string->char-set "0123456789abcdefABCDEF")
 788                 char-set:hex-digit))
 789
 790   (pass-if "char-set:letter+digit"
 791     (char-set<= (char-set-union
 792                  char-set:letter
 793                  char-set:digit)
 794                 char-set:letter+digit))
 795
 796   (pass-if "char-set:punctuation"
 797     (char-set<= (string->char-set
 798                  (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
 799                                 "¡§«¶·»¿"))
 800                 char-set:punctuation))
 801
 802   (pass-if "char-set:symbol"
 803     (char-set<= (string->char-set
 804                  (string-append "$+<=>^`|~"
 805                                 "¢£¤¥¦¨©¬®¯°±´¸×÷"))
 806                 char-set:symbol))
 807
 808   ;; Note that SRFI-14 itself is inconsistent here.  Characters that
 809   ;; are non-digit numbers (such as category No) are clearly 'graphic'
 810   ;; but don't occur in the letter, digit, punct, or symbol charsets.
 811   (pass-if "char-set:graphic"
 812     (char-set<= (char-set-union
 813                  char-set:letter
 814                  char-set:digit
 815                  char-set:punctuation
 816                  char-set:symbol)
 817                 char-set:graphic))
 818
 819   (pass-if "char-set:whitespace"
 820     (char-set<= (string->char-set
 821                  (string
 822                   (integer->char #x09)
 823                   (integer->char #x0a)
 824                   (integer->char #x0b)
 825                   (integer->char #x0c)
 826                   (integer->char #x0d)
 827                   (integer->char #x20)
 828                   (integer->char #xa0)))
 829                 char-set:whitespace))
 830
 831   (pass-if "char-set:printing"
 832     (char-set<= (char-set-union char-set:graphic char-set:whitespace)
 833                 char-set:printing))
 834
 835   (pass-if "char-set:iso-control"
 836     (char-set<= (string->char-set
 837                  (apply string
 838                         (map integer->char (append
 839                                             ;; U+0000 to U+001F
 840                                             (iota #x20)
 841                                             (list #x7f)
 842                                             ;; U+007F to U+009F
 843                                             (map (lambda (x) (+ #x80 x))
 844                                                  (iota #x20))))))
 845                 char-set:iso-control)))