guile18/test-suite/tests/srfi-14.test

   1 ;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
   2 ;;;; Martin Grabmueller, 2001-07-16
   3 ;;;;
   4 ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program 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
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; 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 (with-test-prefix "char-set?"
  34
  35   (pass-if "success on empty set"
  36     (char-set? (char-set)))
  37
  38   (pass-if "success on non-empty set"
  39     (char-set? char-set:printing))
  40
  41   (pass-if "failure on empty set"
  42     (not (char-set? #t))))
  43
  44
  45 (with-test-prefix "char-set="
  46   (pass-if "success, no arg"
  47     (char-set=))
  48
  49   (pass-if "success, one arg"
  50     (char-set= char-set:lower-case))
  51
  52   (pass-if "success, two args"
  53     (char-set= char-set:upper-case char-set:upper-case))
  54
  55   (pass-if "failure, first empty"
  56     (not (char-set= (char-set) (char-set #\a))))
  57
  58   (pass-if "failure, second empty"
  59     (not (char-set= (char-set #\a) (char-set))))
  60
  61   (pass-if "success, more args"
  62     (char-set= char-set:blank char-set:blank char-set:blank)))
  63
  64 (with-test-prefix "char-set<="
  65   (pass-if "success, no arg"
  66     (char-set<=))
  67
  68   (pass-if "success, one arg"
  69     (char-set<= char-set:lower-case))
  70
  71   (pass-if "success, two args"
  72     (char-set<= char-set:upper-case char-set:upper-case))
  73
  74   (pass-if "success, first empty"
  75     (char-set<= (char-set) (char-set #\a)))
  76
  77   (pass-if "failure, second empty"
  78     (not (char-set<= (char-set #\a) (char-set))))
  79
  80   (pass-if "success, more args, equal"
  81     (char-set<= char-set:blank char-set:blank char-set:blank))
  82
  83   (pass-if "success, more args, not equal"
  84     (char-set<= char-set:blank
  85                 (char-set-adjoin char-set:blank #\F)
  86                 (char-set-adjoin char-set:blank #\F #\o))))
  87
  88 (with-test-prefix "char-set-hash"
  89    (pass-if "empty set, bound"
  90       (let ((h (char-set-hash char-set:empty 31)))
  91         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
  92
  93    (pass-if "empty set, no bound"
  94       (let ((h (char-set-hash char-set:empty)))
  95         (and h (number? h) (exact? h) (>= h 0))))
  96
  97    (pass-if "full set, bound"
  98       (let ((h (char-set-hash char-set:full 31)))
  99         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 100
 101    (pass-if "full set, no bound"
 102       (let ((h (char-set-hash char-set:full)))
 103         (and h (number? h) (exact? h) (>= h 0))))
 104
 105    (pass-if "other set, bound"
 106       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
 107         (and h (number? h) (exact? h) (>= h 0) (< h 31))))
 108
 109    (pass-if "other set, no bound"
 110       (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
 111         (and h (number? h) (exact? h) (>= h 0)))))
 112
 113
 114 (with-test-prefix "char-set cursor"
 115
 116   (pass-if-exception "invalid character cursor"
 117      exception:invalid-char-set-cursor
 118      (let* ((cs (char-set #\B #\r #\a #\z))
 119             (cc (char-set-cursor cs)))
 120        (char-set-ref cs 1000)))
 121
 122   (pass-if "success"
 123      (let* ((cs (char-set #\B #\r #\a #\z))
 124             (cc (char-set-cursor cs)))
 125        (char? (char-set-ref cs cc))))
 126
 127   (pass-if "end of set fails"
 128      (let* ((cs (char-set #\a))
 129             (cc (char-set-cursor cs)))
 130        (not (end-of-char-set? cc))))
 131
 132   (pass-if "end of set succeeds, empty set"
 133      (let* ((cs (char-set))
 134             (cc (char-set-cursor cs)))
 135        (end-of-char-set? cc)))
 136
 137   (pass-if "end of set succeeds, non-empty set"
 138      (let* ((cs (char-set #\a))
 139             (cc (char-set-cursor cs))
 140             (cc (char-set-cursor-next cs cc)))
 141        (end-of-char-set? cc))))
 142
 143 (with-test-prefix "char-set-fold"
 144
 145   (pass-if "count members"
 146      (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
 147
 148   (pass-if "copy set"
 149      (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
 150                                       (char-set) (char-set #\a #\b))) 2)))
 151
 152 (with-test-prefix "char-set-unfold"
 153
 154   (pass-if "create char set"
 155      (char-set= char-set:full
 156                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 157                                  (lambda (s) (+ s 1)) 0)))
 158   (pass-if "create char set (base set)"
 159      (char-set= char-set:full
 160                 (char-set-unfold (lambda (s) (= s 256)) integer->char
 161                                  (lambda (s) (+ s 1)) 0 char-set:empty))))
 162
 163 (with-test-prefix "char-set-unfold!"
 164
 165   (pass-if "create char set"
 166      (char-set= char-set:full
 167                 (char-set-unfold! (lambda (s) (= s 256)) integer->char
 168                                  (lambda (s) (+ s 1)) 0
 169                                  (char-set-copy char-set:empty))))
 170
 171   (pass-if "create char set"
 172      (char-set= char-set:full
 173                 (char-set-unfold! (lambda (s) (= s 32)) integer->char
 174                                  (lambda (s) (+ s 1)) 0
 175                                  (char-set-copy char-set:full)))))
 176
 177
 178 (with-test-prefix "char-set-for-each"
 179
 180   (pass-if "copy char set"
 181      (= (char-set-size (let ((cs (char-set)))
 182                          (char-set-for-each
 183                           (lambda (c) (char-set-adjoin! cs c))
 184                           (char-set #\a #\b))
 185                          cs))
 186         2)))
 187
 188 (with-test-prefix "char-set-map"
 189
 190   (pass-if "upper case char set"
 191      (char-set= (char-set-map char-upcase char-set:lower-case)
 192                 char-set:upper-case)))
 193
 194 (with-test-prefix "string->char-set"
 195
 196   (pass-if "some char set"
 197      (let ((chars '(#\g #\u #\i #\l #\e)))
 198        (char-set= (list->char-set chars)
 199                   (string->char-set (apply string chars))))))
 200
 201 ;; Make sure we get an ASCII charset and character classification.
 202 (if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
 203
 204 (with-test-prefix "standard char sets (ASCII)"
 205
 206   (pass-if "char-set:letter"
 207      (char-set= (string->char-set
 208                  (string-append "abcdefghijklmnopqrstuvwxyz"
 209                                 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
 210                 char-set:letter))
 211
 212   (pass-if "char-set:punctuation"
 213      (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
 214                 char-set:punctuation))
 215
 216   (pass-if "char-set:symbol"
 217      (char-set= (string->char-set "$+<=>^`|~")
 218                 char-set:symbol))
 219
 220   (pass-if "char-set:letter+digit"
 221      (char-set= char-set:letter+digit
 222                 (char-set-union char-set:letter char-set:digit)))
 223
 224   (pass-if "char-set:graphic"
 225      (char-set= char-set:graphic
 226                 (char-set-union char-set:letter char-set:digit
 227                                 char-set:punctuation char-set:symbol)))
 228
 229   (pass-if "char-set:printing"
 230       (char-set= char-set:printing
 231                  (char-set-union char-set:whitespace char-set:graphic))))
 232
 233
 234 \f
 235 ;;;
 236 ;;; 8-bit charsets.
 237 ;;;
 238 ;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
 239 ;;; SRFI-14 for implementations supporting this charset is well-defined.
 240 ;;;
 241
 242 (define (every? pred lst)
 243   (not (not (every pred lst))))
 244
 245 (define (find-latin1-locale)
 246   ;; Try to find and install an ISO-8859-1 locale.  Return `#f' on failure.
 247   (if (defined? 'setlocale)
 248       (let loop ((locales (map (lambda (lang)
 249                                  (string-append lang ".iso88591"))
 250                                '("de_DE" "en_GB" "en_US" "es_ES"
 251                                  "fr_FR" "it_IT"))))
 252         (if (null? locales)
 253             #f
 254             (if (false-if-exception (setlocale LC_CTYPE (car locales)))
 255                 (car locales)
 256                 (loop (cdr locales)))))
 257       #f))
 258
 259
 260 (define %latin1 (find-latin1-locale))
 261
 262 (with-test-prefix "Latin-1 (8-bit charset)"
 263
 264   ;; Note: the membership tests below are not exhaustive.
 265
 266   (pass-if "char-set:letter (membership)"
 267      (if (not %latin1)
 268          (throw 'unresolved)
 269          (let ((letters (char-set->list char-set:letter)))
 270            (every? (lambda (8-bit-char)
 271                      (memq 8-bit-char letters))
 272                    (append '(#\a #\b #\c)             ;; ASCII
 273                            (string->list "çéèâùÉÀÈÊ") ;; French
 274                            (string->list "øñÑíßåæðþ"))))))
 275
 276   (pass-if "char-set:letter (size)"
 277      (if (not %latin1)
 278          (throw 'unresolved)
 279          (= (char-set-size char-set:letter) 117)))
 280
 281   (pass-if "char-set:lower-case (size)"
 282      (if (not %latin1)
 283          (throw 'unresolved)
 284          (= (char-set-size char-set:lower-case) (+ 26 33))))
 285
 286   (pass-if "char-set:upper-case (size)"
 287      (if (not %latin1)
 288          (throw 'unresolved)
 289          (= (char-set-size char-set:upper-case) (+ 26 30))))
 290
 291   (pass-if "char-set:punctuation (membership)"
 292      (if (not %latin1)
 293          (throw 'unresolved)
 294          (let ((punctuation (char-set->list char-set:punctuation)))
 295            (every? (lambda (8-bit-char)
 296                      (memq 8-bit-char punctuation))
 297                    (append '(#\! #\. #\?)            ;; ASCII
 298                            (string->list "¡¿")       ;; Castellano
 299                            (string->list "«»"))))))  ;; French
 300
 301   (pass-if "char-set:letter+digit"
 302      (char-set= char-set:letter+digit
 303                 (char-set-union char-set:letter char-set:digit)))
 304
 305   (pass-if "char-set:graphic"
 306      (char-set= char-set:graphic
 307                 (char-set-union char-set:letter char-set:digit
 308                                 char-set:punctuation char-set:symbol)))
 309
 310   (pass-if "char-set:printing"
 311      (char-set= char-set:printing
 312                 (char-set-union char-set:whitespace char-set:graphic))))
 313
 314 ;; Local Variables:
 315 ;; mode: scheme
 316 ;; coding: latin-1
 317 ;; End: