mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
317 lines
9.2 KiB
Text
317 lines
9.2 KiB
Text
;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
|
||
;;;; Martin Grabmueller, 2001-07-16
|
||
;;;;
|
||
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This program is free software; you can redistribute it and/or modify
|
||
;;;; it under the terms of the GNU General Public License as published by
|
||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||
;;;; any later version.
|
||
;;;;
|
||
;;;; This program is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;;; GNU General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU General Public License
|
||
;;;; along with this software; see the file COPYING. If not, write to
|
||
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||
;;;; Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-suite test-srfi-14)
|
||
:use-module (srfi srfi-14)
|
||
:use-module (srfi srfi-1) ;; `every'
|
||
:use-module (test-suite lib))
|
||
|
||
|
||
(define exception:invalid-char-set-cursor
|
||
(cons 'misc-error "^invalid character set cursor"))
|
||
|
||
(define exception:non-char-return
|
||
(cons 'misc-error "returned non-char"))
|
||
|
||
(with-test-prefix "char-set?"
|
||
|
||
(pass-if "success on empty set"
|
||
(char-set? (char-set)))
|
||
|
||
(pass-if "success on non-empty set"
|
||
(char-set? char-set:printing))
|
||
|
||
(pass-if "failure on empty set"
|
||
(not (char-set? #t))))
|
||
|
||
|
||
(with-test-prefix "char-set="
|
||
(pass-if "success, no arg"
|
||
(char-set=))
|
||
|
||
(pass-if "success, one arg"
|
||
(char-set= char-set:lower-case))
|
||
|
||
(pass-if "success, two args"
|
||
(char-set= char-set:upper-case char-set:upper-case))
|
||
|
||
(pass-if "failure, first empty"
|
||
(not (char-set= (char-set) (char-set #\a))))
|
||
|
||
(pass-if "failure, second empty"
|
||
(not (char-set= (char-set #\a) (char-set))))
|
||
|
||
(pass-if "success, more args"
|
||
(char-set= char-set:blank char-set:blank char-set:blank)))
|
||
|
||
(with-test-prefix "char-set<="
|
||
(pass-if "success, no arg"
|
||
(char-set<=))
|
||
|
||
(pass-if "success, one arg"
|
||
(char-set<= char-set:lower-case))
|
||
|
||
(pass-if "success, two args"
|
||
(char-set<= char-set:upper-case char-set:upper-case))
|
||
|
||
(pass-if "success, first empty"
|
||
(char-set<= (char-set) (char-set #\a)))
|
||
|
||
(pass-if "failure, second empty"
|
||
(not (char-set<= (char-set #\a) (char-set))))
|
||
|
||
(pass-if "success, more args, equal"
|
||
(char-set<= char-set:blank char-set:blank char-set:blank))
|
||
|
||
(pass-if "success, more args, not equal"
|
||
(char-set<= char-set:blank
|
||
(char-set-adjoin char-set:blank #\F)
|
||
(char-set-adjoin char-set:blank #\F #\o))))
|
||
|
||
(with-test-prefix "char-set-hash"
|
||
(pass-if "empty set, bound"
|
||
(let ((h (char-set-hash char-set:empty 31)))
|
||
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
|
||
|
||
(pass-if "empty set, no bound"
|
||
(let ((h (char-set-hash char-set:empty)))
|
||
(and h (number? h) (exact? h) (>= h 0))))
|
||
|
||
(pass-if "full set, bound"
|
||
(let ((h (char-set-hash char-set:full 31)))
|
||
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
|
||
|
||
(pass-if "full set, no bound"
|
||
(let ((h (char-set-hash char-set:full)))
|
||
(and h (number? h) (exact? h) (>= h 0))))
|
||
|
||
(pass-if "other set, bound"
|
||
(let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
|
||
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
|
||
|
||
(pass-if "other set, no bound"
|
||
(let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
|
||
(and h (number? h) (exact? h) (>= h 0)))))
|
||
|
||
|
||
(with-test-prefix "char-set cursor"
|
||
|
||
(pass-if-exception "invalid character cursor"
|
||
exception:invalid-char-set-cursor
|
||
(let* ((cs (char-set #\B #\r #\a #\z))
|
||
(cc (char-set-cursor cs)))
|
||
(char-set-ref cs 1000)))
|
||
|
||
(pass-if "success"
|
||
(let* ((cs (char-set #\B #\r #\a #\z))
|
||
(cc (char-set-cursor cs)))
|
||
(char? (char-set-ref cs cc))))
|
||
|
||
(pass-if "end of set fails"
|
||
(let* ((cs (char-set #\a))
|
||
(cc (char-set-cursor cs)))
|
||
(not (end-of-char-set? cc))))
|
||
|
||
(pass-if "end of set succeeds, empty set"
|
||
(let* ((cs (char-set))
|
||
(cc (char-set-cursor cs)))
|
||
(end-of-char-set? cc)))
|
||
|
||
(pass-if "end of set succeeds, non-empty set"
|
||
(let* ((cs (char-set #\a))
|
||
(cc (char-set-cursor cs))
|
||
(cc (char-set-cursor-next cs cc)))
|
||
(end-of-char-set? cc))))
|
||
|
||
(with-test-prefix "char-set-fold"
|
||
|
||
(pass-if "count members"
|
||
(= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
|
||
|
||
(pass-if "copy set"
|
||
(= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
|
||
(char-set) (char-set #\a #\b))) 2)))
|
||
|
||
(with-test-prefix "char-set-unfold"
|
||
|
||
(pass-if "create char set"
|
||
(char-set= char-set:full
|
||
(char-set-unfold (lambda (s) (= s 256)) integer->char
|
||
(lambda (s) (+ s 1)) 0)))
|
||
(pass-if "create char set (base set)"
|
||
(char-set= char-set:full
|
||
(char-set-unfold (lambda (s) (= s 256)) integer->char
|
||
(lambda (s) (+ s 1)) 0 char-set:empty))))
|
||
|
||
(with-test-prefix "char-set-unfold!"
|
||
|
||
(pass-if "create char set"
|
||
(char-set= char-set:full
|
||
(char-set-unfold! (lambda (s) (= s 256)) integer->char
|
||
(lambda (s) (+ s 1)) 0
|
||
(char-set-copy char-set:empty))))
|
||
|
||
(pass-if "create char set"
|
||
(char-set= char-set:full
|
||
(char-set-unfold! (lambda (s) (= s 32)) integer->char
|
||
(lambda (s) (+ s 1)) 0
|
||
(char-set-copy char-set:full)))))
|
||
|
||
|
||
(with-test-prefix "char-set-for-each"
|
||
|
||
(pass-if "copy char set"
|
||
(= (char-set-size (let ((cs (char-set)))
|
||
(char-set-for-each
|
||
(lambda (c) (char-set-adjoin! cs c))
|
||
(char-set #\a #\b))
|
||
cs))
|
||
2)))
|
||
|
||
(with-test-prefix "char-set-map"
|
||
|
||
(pass-if "upper case char set"
|
||
(char-set= (char-set-map char-upcase char-set:lower-case)
|
||
char-set:upper-case)))
|
||
|
||
(with-test-prefix "string->char-set"
|
||
|
||
(pass-if "some char set"
|
||
(let ((chars '(#\g #\u #\i #\l #\e)))
|
||
(char-set= (list->char-set chars)
|
||
(string->char-set (apply string chars))))))
|
||
|
||
;; Make sure we get an ASCII charset and character classification.
|
||
(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
|
||
|
||
(with-test-prefix "standard char sets (ASCII)"
|
||
|
||
(pass-if "char-set:letter"
|
||
(char-set= (string->char-set
|
||
(string-append "abcdefghijklmnopqrstuvwxyz"
|
||
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
|
||
char-set:letter))
|
||
|
||
(pass-if "char-set:punctuation"
|
||
(char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
|
||
char-set:punctuation))
|
||
|
||
(pass-if "char-set:symbol"
|
||
(char-set= (string->char-set "$+<=>^`|~")
|
||
char-set:symbol))
|
||
|
||
(pass-if "char-set:letter+digit"
|
||
(char-set= char-set:letter+digit
|
||
(char-set-union char-set:letter char-set:digit)))
|
||
|
||
(pass-if "char-set:graphic"
|
||
(char-set= char-set:graphic
|
||
(char-set-union char-set:letter char-set:digit
|
||
char-set:punctuation char-set:symbol)))
|
||
|
||
(pass-if "char-set:printing"
|
||
(char-set= char-set:printing
|
||
(char-set-union char-set:whitespace char-set:graphic))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; 8-bit charsets.
|
||
;;;
|
||
;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
|
||
;;; SRFI-14 for implementations supporting this charset is well-defined.
|
||
;;;
|
||
|
||
(define (every? pred lst)
|
||
(not (not (every pred lst))))
|
||
|
||
(define (find-latin1-locale)
|
||
;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure.
|
||
(if (defined? 'setlocale)
|
||
(let loop ((locales (map (lambda (lang)
|
||
(string-append lang ".iso88591"))
|
||
'("de_DE" "en_GB" "en_US" "es_ES"
|
||
"fr_FR" "it_IT"))))
|
||
(if (null? locales)
|
||
#f
|
||
(if (false-if-exception (setlocale LC_CTYPE (car locales)))
|
||
(car locales)
|
||
(loop (cdr locales)))))
|
||
#f))
|
||
|
||
|
||
(define %latin1 (find-latin1-locale))
|
||
|
||
(with-test-prefix "Latin-1 (8-bit charset)"
|
||
|
||
;; Note: the membership tests below are not exhaustive.
|
||
|
||
(pass-if "char-set:letter (membership)"
|
||
(if (not %latin1)
|
||
(throw 'unresolved)
|
||
(let ((letters (char-set->list char-set:letter)))
|
||
(every? (lambda (8-bit-char)
|
||
(memq 8-bit-char letters))
|
||
(append '(#\a #\b #\c) ;; ASCII
|
||
(string->list "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>") ;; French
|
||
(string->list "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"))))))
|
||
|
||
(pass-if "char-set:letter (size)"
|
||
(if (not %latin1)
|
||
(throw 'unresolved)
|
||
(= (char-set-size char-set:letter) 117)))
|
||
|
||
(pass-if "char-set:lower-case (size)"
|
||
(if (not %latin1)
|
||
(throw 'unresolved)
|
||
(= (char-set-size char-set:lower-case) (+ 26 33))))
|
||
|
||
(pass-if "char-set:upper-case (size)"
|
||
(if (not %latin1)
|
||
(throw 'unresolved)
|
||
(= (char-set-size char-set:upper-case) (+ 26 30))))
|
||
|
||
(pass-if "char-set:punctuation (membership)"
|
||
(if (not %latin1)
|
||
(throw 'unresolved)
|
||
(let ((punctuation (char-set->list char-set:punctuation)))
|
||
(every? (lambda (8-bit-char)
|
||
(memq 8-bit-char punctuation))
|
||
(append '(#\! #\. #\?) ;; ASCII
|
||
(string->list "<22><>") ;; Castellano
|
||
(string->list "<22><>")))))) ;; French
|
||
|
||
(pass-if "char-set:letter+digit"
|
||
(char-set= char-set:letter+digit
|
||
(char-set-union char-set:letter char-set:digit)))
|
||
|
||
(pass-if "char-set:graphic"
|
||
(char-set= char-set:graphic
|
||
(char-set-union char-set:letter char-set:digit
|
||
char-set:punctuation char-set:symbol)))
|
||
|
||
(pass-if "char-set:printing"
|
||
(char-set= char-set:printing
|
||
(char-set-union char-set:whitespace char-set:graphic))))
|
||
|
||
;; Local Variables:
|
||
;; mode: scheme
|
||
;; coding: latin-1
|
||
;; End:
|