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 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
  57 (with-test-prefix "char-set?"
  58
  59   (pass-if "success on empty set"
  60     (char-set? (char-set)))
  61
  62   (pass-if "success on non-empty set"
  63     (char-set? char-set:printing))
  64
  65   (pass-if "failure on empty set"
  66     (not (char-set? #t))))
  67
  68
  69 (with-test-prefix "char-set="
  70   (pass-if "success, no arg"
  71     (char-set=))
  72
  73   (pass-if "success, one arg"
  74     (char-set= char-set:lower-case))
  75
  76   (pass-if "success, two args"
  77     (char-set= char-set:upper-case char-set:upper-case))
  78
  79   (pass-if "failure, first empty"
  80     (not (char-set= (char-set) (char-set #\a))))
  81
  82   (pass-if "failure, second empty"
  83     (not (char-set= (char-set #\a) (char-set))))
  84
  85   (pass-if "success, more args"
  86     (char-set= char-set:blank char-set:blank char-set:blank)))
  87
  88 (with-test-prefix "char-set<="
  89   (pass-if "success, no arg"
  90     (char-set<=))
  91
  92   (pass-if "success, one arg"
  93     (char-set<= char-set:lower-case))
  94
  95   (pass-if "success, two args"
  96     (char-set<= char-set:upper-case char-set:upper-case))
  97
  98   (pass-if "success, first empty"
  99     (char-set<= (char-set) (char-set #\a)))
 100
 101   (pass-if "failure, second empty"
 102     (not (char-set<= (char-set #\a) (char-set))))
 103
 104   (pass-if "success, more args, equal"
 105     (char-set<= char-set:blank char-set:blank char-set:blank))
 106
 107   (pass-if "success, more args, not equal"
 108     (char-set<= char-set:blank
 109                 (char-set-adjoin char-set:blank #\F)
 110                 (char-set-adjoin char-set:blank #\F #\o))))
 111
 112 (with-test-prefix "char-set-hash"
 113    (pass-if "empty set, bound"
 114       (let ((h (char-set-hash char-set:empty 31)))
 115         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 116
 117    (pass-if "empty set, no bound"
 118       (let ((h (char-set-hash char-set:empty)))
 119         (and h (number? h) (exact? h) (>= h 0))))
 120
 121    (pass-if "full set, bound"
 122       (let ((h (char-set-hash char-set:full 31)))
 123         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 124
 125    (pass-if "full set, no bound"
 126       (let ((h (char-set-hash char-set:full)))
 127         (and h (number? h) (exact? h) (>= h 0))))
 128
 129    (pass-if "other set, bound"
 130       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
 131         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 132
 133    (pass-if "other set, no bound"
 134       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
 135         (and h (number? h) (exact? h) (>= h 0)))))
 136
 137
 138 (with-test-prefix "char-set cursor"
 139
 140   (pass-if-exception "invalid character cursor"
 141      exception:wrong-type-arg
 142      (let* ((cs (char-set #\B #\r #\a #\z))
 143             (cc (char-set-cursor cs)))
 144        (char-set-ref cs 1000)))
 145
 146   (pass-if "success"
 147      (let* ((cs (char-set #\B #\r #\a #\z))
 148             (cc (char-set-cursor cs)))
 149        (char? (char-set-ref cs cc))))
 150
 151   (pass-if "end of set fails"
 152      (let* ((cs (char-set #\a))
 153             (cc (char-set-cursor cs)))
 154        (not (end-of-char-set? cc))))
 155
 156   (pass-if "end of set succeeds, empty set"
 157      (let* ((cs (char-set))
 158             (cc (char-set-cursor cs)))
 159        (end-of-char-set? cc)))
 160
 161   (pass-if "end of set succeeds, non-empty set"
 162      (let* ((cs (char-set #\a))
 163             (cc (char-set-cursor cs))
 164             (cc (char-set-cursor-next cs cc)))
 165        (end-of-char-set? cc))))
 166
 167 (with-test-prefix "char-set-fold"
 168
 169   (pass-if "count members"
 170      (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
 171
 172   (pass-if "copy set"
 173      (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
 174                                       (char-set) (char-set #\a #\b))) 2)))
 175
 176 (define char-set:256
 177   (string->char-set (apply string (map integer->char (iota 256)))))
 178
 179 (with-test-prefix "char-set-unfold"
 180
 181   (pass-if "create char set"
 182      (char-set= char-set:256
 183                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 184                                  (lambda (s) (+ s 1)) 0)))
 185   (pass-if "create char set (base set)"
 186      (char-set= char-set:256
 187                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 188                                  (lambda (s) (+ s 1)) 0 char-set:empty))))
 189
 190 (with-test-prefix "char-set-unfold!"
 191
 192   (pass-if "create char set"
 193      (char-set= char-set:256
 194                 (char-set-unfold! (lambda (s) (= s 256)) integer->char
 195                                  (lambda (s) (+ s 1)) 0
 196                                  (char-set-copy char-set:empty))))
 197
 198   (pass-if "create char set"
 199      (char-set= char-set:256
 200                 (char-set-unfold! (lambda (s) (= s 32)) integer->char
 201                                  (lambda (s) (+ s 1)) 0
 202                                  (char-set-copy char-set:256)))))
 203
 204
 205 (with-test-prefix "char-set-for-each"
 206
 207   (pass-if "copy char set"
 208      (= (char-set-size (let ((cs (char-set)))
 209                          (char-set-for-each
 210                           (lambda (c) (char-set-adjoin! cs c))
 211                           (char-set #\a #\b))
 212                          cs))
 213         2)))
 214
 215 (with-test-prefix "char-set-map"
 216
 217   (pass-if "upper case char set 1"
 218      (char-set= (char-set-map char-upcase
 219                               (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 220                 (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
 221
 222   (pass-if "upper case char set 2"
 223      (char-set= (char-set-map char-upcase
 224                               (string->char-set "àáâãäåæçèéêëìíîïñòóôõöøùúûüýþ"))
 225                 (string->char-set "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝÞ"))))
 226
 227 (with-test-prefix "string->char-set"
 228
 229   (pass-if "some char set"
 230      (let ((chars '(#\g #\u #\i #\l #\e)))
 231        (char-set= (list->char-set chars)
 232                   (string->char-set (apply string chars))))))
 233
 234 (with-test-prefix "char-set->string"
 235
 236   (pass-if "some char set"
 237      (let ((cs (char-set #\g #\u #\i #\l #\e)))
 238        (string=? (char-set->string cs)
 239                  "egilu"))))
 240
 241 (with-test-prefix "standard char sets (ASCII)"
 242
 243   (pass-if "char-set:lower-case"
 244      (char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz")
 245                  char-set:lower-case))
 246
 247   (pass-if "char-set:upper-case"
 248      (char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 249                  char-set:upper-case))
 250
 251   (pass-if "char-set:title-case"
 252      (char-set<= (string->char-set "")
 253                  char-set:title-case))
 254
 255   (pass-if "char-set:letter"
 256      (char-set<= (char-set-union
 257                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 258                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
 259                  char-set:letter))
 260
 261   (pass-if "char-set:digit"
 262      (char-set<= (string->char-set "0123456789")
 263                  char-set:digit))
 264
 265   (pass-if "char-set:hex-digit"
 266      (char-set<= (string->char-set "0123456789abcdefABCDEF")
 267                  char-set:hex-digit))
 268
 269   (pass-if "char-set:letter+digit"
 270      (char-set<= (char-set-union
 271                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 272                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 273                   (string->char-set "0123456789"))
 274                  char-set:letter+digit))
 275
 276   (pass-if "char-set:punctuation"
 277      (char-set<= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 278                  char-set:punctuation))
 279
 280   (pass-if "char-set:symbol"
 281      (char-set<= (string->char-set "$+<=>^`|~")
 282                  char-set:symbol))
 283
 284   (pass-if "char-set:graphic"
 285      (char-set<= (char-set-union
 286                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 287                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 288                   (string->char-set "0123456789")
 289                   (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 290                   (string->char-set "$+<=>^`|~"))
 291                  char-set:graphic))
 292
 293   (pass-if "char-set:whitespace"
 294      (char-set<= (string->char-set
 295                   (string
 296                    (integer->char #x09)
 297                    (integer->char #x0a)
 298                    (integer->char #x0b)
 299                    (integer->char #x0c)
 300                    (integer->char #x0d)
 301                    (integer->char #x20)))
 302                  char-set:whitespace))
 303
 304   (pass-if "char-set:printing"
 305      (char-set<= (char-set-union
 306                   (string->char-set "abcdefghijklmnopqrstuvwxyz")
 307                   (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 308                   (string->char-set "0123456789")
 309                   (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 310                   (string->char-set "$+<=>^`|~")
 311                   (string->char-set (string
 312                                      (integer->char #x09)
 313                                      (integer->char #x0a)
 314                                      (integer->char #x0b)
 315                                      (integer->char #x0c)
 316                                      (integer->char #x0d)
 317                                      (integer->char #x20))))
 318                  char-set:printing))
 319
 320   (pass-if "char-set:iso-control"
 321      (char-set<= (string->char-set
 322                   (apply string
 323                          (map integer->char (append
 324                                              ;; U+0000 to U+001F
 325                                              (iota #x20)
 326                                              (list #x7f)))))
 327                  char-set:iso-control)))
 328
 329 \f
 330 ;;;
 331 ;;; Non-ASCII codepoints
 332 ;;;
 333 ;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
 334 ;;; SRFI-14 for implementations supporting this charset is well-defined.
 335 ;;;
 336
 337 (define (every? pred lst)
 338   (not (not (every pred lst))))
 339
 340 (define oldlocale #f)
 341 (if (defined? 'setlocale)
 342     (set! oldlocale (setlocale LC_ALL "")))
 343
 344 (with-test-prefix "Latin-1 (8-bit charset)"
 345
 346   (pass-if "char-set:lower-case"
 347     (char-set<= (string->char-set
 348                  (string-append "abcdefghijklmnopqrstuvwxyz"
 349                                 "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")
 350                  char-set:lower-case)))
 351
 352   (pass-if "char-set:upper-case"
 353     (char-set<= (string->char-set
 354                  (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 355                                 "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ")
 356                  char-set:lower-case)))
 357
 358   (pass-if "char-set:title-case"
 359     (char-set<= (string->char-set "")
 360                 char-set:title-case))
 361
 362   (pass-if "char-set:letter"
 363     (char-set<= (string->char-set
 364                  (string-append
 365                   ;; Lowercase
 366                   "abcdefghijklmnopqrstuvwxyz"
 367                   "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"
 368                   ;; Uppercase
 369                   "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 370                   "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
 371                   ;; Uncased
 372                   "ªº"))
 373                 char-set:letter))
 374
 375   (pass-if "char-set:digit"
 376     (char-set<= (string->char-set "0123456789")
 377                 char-set:digit))
 378
 379   (pass-if "char-set:hex-digit"
 380     (char-set<= (string->char-set "0123456789abcdefABCDEF")
 381                 char-set:hex-digit))
 382
 383   (pass-if "char-set:letter+digit"
 384     (char-set<= (char-set-union
 385                  char-set:letter
 386                  char-set:digit)
 387                 char-set:letter+digit))
 388
 389   (pass-if "char-set:punctuation"
 390     (char-set<= (string->char-set
 391                  (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
 392                                 "¡«·»¿"))
 393                 char-set:punctuation))
 394
 395   (pass-if "char-set:symbol"
 396     (char-set<= (string->char-set
 397                  (string-append "$+<=>^`|~"
 398                                 "¢£¤¥¦§¨©¬®¯°±´¶¸×÷"))
 399                 char-set:symbol))
 400
 401   ;; Note that SRFI-14 itself is inconsistent here.  Characters that
 402   ;; are non-digit numbers (such as category No) are clearly 'graphic'
 403   ;; but don't occur in the letter, digit, punct, or symbol charsets.
 404   (pass-if "char-set:graphic"
 405     (char-set<= (char-set-union
 406                  char-set:letter
 407                  char-set:digit
 408                  char-set:punctuation
 409                  char-set:symbol)
 410                 char-set:graphic))
 411
 412   (pass-if "char-set:whitespace"
 413     (char-set<= (string->char-set
 414                  (string
 415                   (integer->char #x09)
 416                   (integer->char #x0a)
 417                   (integer->char #x0b)
 418                   (integer->char #x0c)
 419                   (integer->char #x0d)
 420                   (integer->char #x20)
 421                   (integer->char #xa0)))
 422                 char-set:whitespace))
 423
 424   (pass-if "char-set:printing"
 425     (char-set<= (char-set-union char-set:graphic char-set:whitespace)
 426                 char-set:printing))
 427
 428   (pass-if "char-set:iso-control"
 429     (char-set<= (string->char-set
 430                  (apply string
 431                         (map integer->char (append
 432                                             ;; U+0000 to U+001F
 433                                             (iota #x20)
 434                                             (list #x7f)
 435                                             ;; U+007F to U+009F
 436                                             (map (lambda (x) (+ #x80 x))
 437                                                  (iota #x20))))))
 438                 char-set:iso-control)))
 439
 440 (if (defined? 'setlocale)
 441     (setlocale LC_ALL oldlocale))