mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 11:34:09 +02:00
Code Activity
guile/test-suite/tests/srfi-14.test
Michael Gran f49dbcadf3 Unicode-capable srfi-14 charsets 
* libguile/Makefile.am: distribute new files srfi-14.i.c and
  unidata_to_charset.pl

* chars.c (scm_c_upcase, scm_c_downcase): use unicode-enable toupper
  and tolower

* libguile/srfi-14.h (scm_t_char_range, scm_t_char_set): new structures
  to describe char-sets
  (scm_t_char_set_cursor): new structure to describe char-set-cursors
  (SCM_BITS_PER_LONG): removed
  (SCM_CHARSET_GET): calls function
  New declarations for scm_i_charset_get, scm_i_charset_set,
  scm_i_charset_unset, and scm_debug_char_set.

* test-suite/tests/srfi-14.test: new tests

* libguile/srfi-14.c (SCM_CHARSET_DATA): new macro
  (SCM_CHARSET_SET, SCM_CHARSET_UNSET): call function
  (BYTES_PER_CHARSET, LONGS_PER_CHARSET): removed
  (scm_i_charset_get, scm_i_charset_set, scm_i_charset_unset)
  (charsets_equal, charsets_leq, charsets_union)
  (charsets_intersection, charsets_complement, charsets_xor): new
  functions that are low-level charset operators
  (charset_print, charset_free): modified for new charset struct
  (charset_cursor_print, charset_cursor_free): new function
  (make_char_set, scm_char_set_p, scm_char_set_eq, scm_car_set_leq)
  (scm_char_set_hash, scm_char_set_cursor, scm_char_set_ref)
  (scm_char_set_cursor_next, scm_end_of_char_set_p, scm_char_set_fold)
  (scm_char_set_unfold, scm_char_set_unfold_x, scm_char_set_for_each)
  (scm_char_set_map, scm_char_set_copy, scm_char_set, scm_list_to_char_set)
  (scm_list_to_char_set_x, scm_string_to_char_set, scm_string_to_char_set_x)
  (scm_char_set_filter, scm_char_set_filter_x, scm_ucs_range_to_char_set)
  (scm_ucs_range_to_char_set_x, scm_to_char_set, scm_char_set_size)
  (scm_char_set_count, scm_char_set_to_list, scm_char_set_to_string)
  (scm_char_set_contains_p, scm_char_set_every, scm_char_set_any)
  (scm_char_set_adjoin, scm_char_set_delete, scm_char_set_adjoin_x)
  (scm_char_set_delete_x, scm_char_set_complement, scm_char_set_union)
  (scm_char_set_intersection, scm_char_set_difference, scm_char_set_xor)
  (scm_char_set_diff_plus_intersection, scm_char_set_complement_x)
  (scm_char_set_union_x, scm_char_set_intersection_x, scm_char_set_difference_x)
  (scm_char_set_xor_x, scm_char_set_diff_plus_intersection_x): modified
  to use new charset and charset-cursor data structures
  (CSET_BLANK_PRED, CSET_SYMBOL_PRED, CSET_PUNCT_PRED, CSET_LOWER_PRED)
  (CSET_UPPER_PRED, CSET_LETTER_PRED, CSET_DIGIT_PRED, CSET_WHITESPACE_PRED)
  (CSET_CONTROL_PRED, CSET_HEX_DIGIT_PRED, CSET_ASCII_PRED, CSET_LETTER_PRED)
  (CSET_LETTER_AND_DIGIT_PRED, CSET_PRINTING_PRED, CSET_TRUE_PRED)
  (CSET_FALSE_PRED): removed
  (scm_srfi_14_compute_char_sets): removed - too slow to iterate
  over all of unicode at startup
  (scm_debug_char_set) [SCM_CHARSET_DEBUG]: new function
2009-08-27 07:43:33 -07:00

481 lines
15 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; srfi-14.test -*- mode:scheme; coding: iso-8859-1 -*-
;;;; --- Test suite for Guile's SRFI-14 functions.
;;;; Martin Grabmueller, 2001-07-16
;;;;
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; 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 contents"
(pass-if "empty set"
(list= eqv?
(char-set->list (char-set))
'()))
(pass-if "single char"
(list= eqv?
(char-set->list (char-set #\a))
(list #\a)))
(pass-if "contiguous chars"
(list= eqv?
(char-set->list (char-set #\a #\b #\c))
(list #\a #\b #\c)))
(pass-if "discontiguous chars"
(list= eqv?
(char-set->list (char-set #\a #\c #\e))
(list #\a #\c #\e))))
(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:wrong-type-arg
(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)))
(define char-set:256
(string->char-set (apply string (map integer->char (iota 256)))))
(with-test-prefix "char-set-unfold"
(pass-if "create char set"
(char-set= char-set:256
(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:256
(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:256
(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:256
(char-set-unfold! (lambda (s) (= s 32)) integer->char
(lambda (s) (+ s 1)) 0
(char-set-copy char-set:256)))))
(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 1"
(char-set= (char-set-map char-upcase
(string->char-set "abcdefghijklmnopqrstuvwxyz"))
(string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
(pass-if "upper case char set 2"
(char-set= (char-set-map char-upcase
(string->char-set "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"))
(string->char-set "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"))))
(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))))))
(with-test-prefix "char-set->string"
(pass-if "some char set"
(let ((cs (char-set #\g #\u #\i #\l #\e)))
(string=? (char-set->string cs)
"egilu"))))
;; 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:lower-case"
(char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz")
char-set:lower-case))
(pass-if "char-set:upper-case"
(char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
char-set:upper-case))
(pass-if "char-set:title-case"
(char-set<= (string->char-set "")
char-set:title-case))
(pass-if "char-set:letter"
(char-set<= (char-set-union
(string->char-set "abcdefghijklmnopqrstuvwxyz")
(string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
char-set:letter))
(pass-if "char-set:digit"
(char-set<= (string->char-set "0123456789")
char-set:digit))
(pass-if "char-set:hex-digit"
(char-set<= (string->char-set "0123456789abcdefABCDEF")
char-set:hex-digit))
(pass-if "char-set:letter+digit"
(char-set<= (char-set-union
(string->char-set "abcdefghijklmnopqrstuvwxyz")
(string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(string->char-set "0123456789"))
char-set:letter+digit))
(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:graphic"
(char-set<= (char-set-union
(string->char-set "abcdefghijklmnopqrstuvwxyz")
(string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(string->char-set "0123456789")
(string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
(string->char-set "$+<=>^`|~"))
char-set:graphic))
(pass-if "char-set:whitespace"
(char-set<= (string->char-set
(string
(integer->char #x09)
(integer->char #x0a)
(integer->char #x0b)
(integer->char #x0c)
(integer->char #x0d)
(integer->char #x20)))
char-set:whitespace))
(pass-if "char-set:printing"
(char-set<= (char-set-union
(string->char-set "abcdefghijklmnopqrstuvwxyz")
(string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(string->char-set "0123456789")
(string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
(string->char-set "$+<=>^`|~")
(string->char-set (string
(integer->char #x09)
(integer->char #x0a)
(integer->char #x0b)
(integer->char #x0c)
(integer->char #x0d)
(integer->char #x20))))
char-set:printing))
(pass-if "char-set:iso-control"
(char-set<= (string->char-set
(apply string
(map integer->char (append
;; U+0000 to U+001F
(iota #x20)
(list #x7f)))))
char-set:iso-control)))
;;;
;;; Non-ASCII codepoints
;;;
;;; 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)"
(pass-if "char-set:lower-case"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string-append "abcdefghijklmnopqrstuvwxyz"
"<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
char-set:lower-case))))
(pass-if "char-set:upper-case"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
char-set:lower-case))))
(pass-if "char-set:title-case"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set "")
char-set:title-case)))
(pass-if "char-set:letter"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string-append
;; Lowercase
"abcdefghijklmnopqrstuvwxyz"
"<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
;; Uppercase
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
;; Uncased
"<22><>"))
char-set:letter)))
(pass-if "char-set:digit"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set "0123456789")
char-set:digit)))
(pass-if "char-set:hex-digit"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set "0123456789abcdefABCDEF")
char-set:hex-digit)))
(pass-if "char-set:letter+digit"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (char-set-union
char-set:letter
char-set:digit)
char-set:letter+digit)))
(pass-if "char-set:punctuation"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string-append "!\"#%&'()*,-./:;?@[\\]_{}"
"<22><><EFBFBD><EFBFBD><EFBFBD>"))
char-set:punctuation)))
(pass-if "char-set:symbol"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string-append "$+<=>^`|~"
"<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"))
char-set:symbol)))
;; Note that SRFI-14 itself is inconsistent here. Characters that
;; are non-digit numbers (such as category No) are clearly 'graphic'
;; but don't occur in the letter, digit, punct, or symbol charsets.
(pass-if "char-set:graphic"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (char-set-union
char-set:letter
char-set:digit
char-set:punctuation
char-set:symbol)
char-set:graphic)))
(pass-if "char-set:whitespace"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(string
(integer->char #x09)
(integer->char #x0a)
(integer->char #x0b)
(integer->char #x0c)
(integer->char #x0d)
(integer->char #x20)
(integer->char #xa0)))
char-set:whitespace)))
(pass-if "char-set:printing"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (char-set-union char-set:graphic char-set:whitespace)
char-set:printing)))
(pass-if "char-set:iso-control"
(if (not %latin1)
(throw 'unresolved)
(char-set<= (string->char-set
(apply string
(map integer->char (append
;; U+0000 to U+001F
(iota #x20)
(list #x7f)
;; U+007F to U+009F
(map (lambda (x) (+ #x80 x))
(iota #x20))))))
char-set:iso-control))))
View git blame Copy permalink