mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-02 23:50:47 +02:00
7a1406891f
Also deprecate the C interface. * libguile/deprecated.h: * libguile/deprecated.c (scm_char_set_cursor): (scm_char_set_ref): (scm_char_set_cursor_next): (scm_end_of_char_set_p): Deprecate. * libguile/srfi-14.c (charset-mutable?, char-set-ranges) (charset-set-ranges!): New accessors, exposed internally to srfi-14.scm. * libguile/srfi-14.c (scm_boot_srfi_14): Remove scm_tc16_charset_cursor. * module/srfi/srfi-14.scm (<char-set-cursor>): Implement as a record.
185 lines
6.2 KiB
Scheme
185 lines
6.2 KiB
Scheme
;;; srfi-14.scm --- Character-set Library
|
|
|
|
;; Copyright (C) 2001, 2002, 2004, 2006, 2025 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
|
|
|
|
;;; Commentary:
|
|
|
|
;; This module is fully documented in the Guile Reference Manual.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (srfi srfi-14)
|
|
;; FIXME: Use #:export instead of #:replace once deprecated bindings
|
|
;; are removed.
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (rnrs bytevectors)
|
|
#:replace (;; General procedures
|
|
char-set?
|
|
char-set=
|
|
char-set<=
|
|
char-set-hash
|
|
|
|
;; Iterating over character sets
|
|
char-set-cursor
|
|
char-set-ref
|
|
char-set-cursor-next
|
|
end-of-char-set?
|
|
char-set-fold
|
|
char-set-unfold char-set-unfold!
|
|
char-set-for-each
|
|
char-set-map
|
|
|
|
;; Creating character sets
|
|
char-set-copy
|
|
char-set
|
|
list->char-set list->char-set!
|
|
string->char-set string->char-set!
|
|
char-set-filter char-set-filter!
|
|
ucs-range->char-set ucs-range->char-set!
|
|
->char-set
|
|
|
|
;; Querying character sets
|
|
char-set-size
|
|
char-set-count
|
|
char-set->list
|
|
char-set->string
|
|
char-set-contains?
|
|
char-set-every
|
|
char-set-any
|
|
|
|
;; Character set algebra
|
|
char-set-adjoin char-set-adjoin!
|
|
char-set-delete char-set-delete!
|
|
char-set-complement
|
|
char-set-union
|
|
char-set-intersection
|
|
char-set-difference
|
|
char-set-xor
|
|
char-set-diff+intersection
|
|
char-set-complement!
|
|
char-set-union!
|
|
char-set-intersection!
|
|
char-set-difference!
|
|
char-set-xor!
|
|
char-set-diff+intersection!
|
|
|
|
;; Standard character sets
|
|
char-set:lower-case
|
|
char-set:upper-case
|
|
char-set:title-case
|
|
char-set:letter
|
|
char-set:digit
|
|
char-set:letter+digit
|
|
char-set:graphic
|
|
char-set:printing
|
|
char-set:whitespace
|
|
char-set:iso-control
|
|
char-set:punctuation
|
|
char-set:symbol
|
|
char-set:hex-digit
|
|
char-set:blank
|
|
char-set:ascii
|
|
char-set:empty
|
|
char-set:full))
|
|
|
|
(eval-when (expand load eval)
|
|
(load-extension (string-append "libguile-" (effective-version))
|
|
"scm_init_srfi_14"))
|
|
|
|
(define-record-type <char-set-cursor>
|
|
(make-char-set-cursor cs range n limit)
|
|
char-set-cursor?
|
|
(cs char-set-cursor-charset)
|
|
(range char-set-cursor-range set-char-set-cursor-range!)
|
|
(n char-set-cursor-n set-char-set-cursor-n!)
|
|
(limit char-set-cursor-limit set-char-set-cursor-limit!))
|
|
|
|
(define (charset-ranges-len ranges)
|
|
(ash (bytevector-length ranges) -3))
|
|
|
|
(define (charset-range-lo ranges idx)
|
|
(bytevector-u32-native-ref ranges (ash idx 3)))
|
|
(define (charset-range-hi ranges idx)
|
|
(bytevector-u32-native-ref ranges (+ (ash idx 3) 4)))
|
|
|
|
(define (char-set-cursor cs)
|
|
"Return a cursor into the character set @var{cs}."
|
|
(let* ((ranges (charset-ranges cs))
|
|
(len (charset-ranges-len ranges)))
|
|
(if (zero? len)
|
|
(make-char-set-cursor cs #f #f #f)
|
|
(make-char-set-cursor cs 0 (charset-range-lo ranges 0)
|
|
(charset-range-hi ranges 0)))))
|
|
|
|
(define (char-set-ref cs cursor)
|
|
"Return the character at the current cursor position @var{cursor} in the
|
|
character set @var{cs}. It is an error to pass a cursor for which
|
|
@code{end-of-char-set?} returns true."
|
|
(match cursor
|
|
(($ <char-set-cursor> cs* range n limit)
|
|
(unless (eq? cs cs*)
|
|
(error "charset cursors can only be used with their original charsets"
|
|
cursor))
|
|
(unless n
|
|
(error "char-set-ref on cursor that is end-of-char-set?" cursor))
|
|
(integer->char n))
|
|
(_
|
|
(scm-error 'wrong-type-arg "char-set-ref" "Wrong type argument: ~S"
|
|
(list cursor)
|
|
'()))))
|
|
|
|
(define (char-set-cursor-next cs cursor)
|
|
"Advance the character set cursor @var{cursor} to the next character in
|
|
the character set @var{cs}. It is an error if the cursor given
|
|
satisfies @code{end-of-char-set?}."
|
|
(match cursor
|
|
(($ <char-set-cursor> cs* range n limit)
|
|
(unless (eq? cs cs*)
|
|
(error "charset cursors can only be used with their original charsets"
|
|
cursor))
|
|
(unless n
|
|
(error "char-set-next on cursor that is end-of-char-set?" cursor))
|
|
(cond
|
|
((< n limit)
|
|
(set-char-set-cursor-n! cursor (1+ n)))
|
|
(else
|
|
(let* ((ranges (charset-ranges cs))
|
|
(len (charset-ranges-len ranges)))
|
|
(cond
|
|
((< (1+ range) len)
|
|
(set-char-set-cursor-range! cursor (1+ range))
|
|
(set-char-set-cursor-n! cursor (charset-range-lo cs range))
|
|
(set-char-set-cursor-limit! cursor (charset-range-hi cs range)))
|
|
(else
|
|
(set-char-set-cursor-range! cursor #f)
|
|
(set-char-set-cursor-n! cursor #f)
|
|
(set-char-set-cursor-limit! cursor #f))))))
|
|
cursor)
|
|
(_
|
|
(scm-error 'wrong-type-arg "char-set-ref" "Wrong type argument: ~S"
|
|
(list cursor)
|
|
'()))))
|
|
|
|
(define (end-of-char-set? cursor)
|
|
"Return @code{#t} if @var{cursor} has reached the end of a character set,
|
|
@code{#f} otherwise."
|
|
(not (char-set-cursor-range cursor)))
|
|
|
|
(cond-expand-provide (current-module) '(srfi-14))
|
|
|
|
;;; srfi-14.scm ends here
|