;;; 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