mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
86 lines
3.5 KiB
Scheme
86 lines
3.5 KiB
Scheme
;;; R7RS compatibility libraries
|
|
;;; Copyright (C) 2019, 2023 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 program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Based on code from https://gitlab.com/akku/akku-scm, written
|
|
;;; 2018-2019 by Göran Weinholt <goran@weinholt.se>, as well as
|
|
;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
|
|
;;; <mjt@cltn.org>. This code was originally released under the
|
|
;;; following terms:
|
|
;;;
|
|
;;; To the extent possible under law, the author(s) have dedicated
|
|
;;; all copyright and related and neighboring rights to this
|
|
;;; software to the public domain worldwide. This software is
|
|
;;; distributed without any warranty.
|
|
;;;
|
|
;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
|
|
;;; copy of the CC0 Public Domain Dedication.
|
|
|
|
(define-module (scheme char)
|
|
#:use-module ((srfi srfi-43) #:select (vector-binary-search))
|
|
#:use-module (ice-9 i18n)
|
|
#:export (char-foldcase
|
|
string-foldcase
|
|
digit-value)
|
|
#:re-export (char-alphabetic?
|
|
char-ci<=? char-ci<? char-ci=? char-ci>=?
|
|
char-ci>? char-downcase char-lower-case?
|
|
char-numeric? char-upcase char-upper-case? char-whitespace?
|
|
string-ci<=? string-ci<? string-ci=?
|
|
string-ci>=? string-ci>?
|
|
(string-locale-downcase . string-downcase)
|
|
(string-locale-upcase . string-upcase)))
|
|
|
|
(define (char-foldcase char)
|
|
(if (or (eqv? char #\460) (eqv? char #\461))
|
|
char
|
|
(char-downcase (char-upcase char))))
|
|
|
|
(define (string-foldcase str)
|
|
(string-locale-downcase (string-locale-upcase str)))
|
|
|
|
;; The table can be extracted with:
|
|
;; awk -F ';' '/ZERO;Nd/ {print "#x"$1}' UnicodeData.txt
|
|
;; Up to date with Unicode 15.1.0
|
|
|
|
(define *decimal-zeroes* '#(#x0030 #x0660 #x06F0 #x07C0 #x0966 #x09E6
|
|
#x0A66 #x0AE6 #x0B66 #x0BE6 #x0C66 #x0CE6 #x0D66 #x0DE6 #x0E50
|
|
#x0ED0 #x0F20 #x1040 #x1090 #x17E0 #x1810 #x1946 #x19D0 #x1A80
|
|
#x1A90 #x1B50 #x1BB0 #x1C40 #x1C50 #xA620 #xA8D0 #xA900 #xA9D0
|
|
#xA9F0 #xAA50 #xABF0 #xFF10 #x104A0 #x10D30 #x11066 #x110F0 #x11136
|
|
#x111D0 #x112F0 #x11450 #x114D0 #x11650 #x116C0 #x11730 #x118E0
|
|
#x11950 #x11C50 #x11D50 #x11DA0 #x11F50 #x16A60 #x16AC0 #x16B50
|
|
#x1D7CE #x1D7D8 #x1D7E2 #x1D7EC #x1D7F6 #x1E140 #x1E2F0 #x1E4F0
|
|
#x1E950 #x1FBF0))
|
|
|
|
(define (digit-value char)
|
|
(define (cmp zero ch)
|
|
(if (integer? ch)
|
|
(- (cmp zero ch))
|
|
(let ((i (char->integer ch)))
|
|
(cond ((< i zero) 1)
|
|
((> i (+ zero 9)) -1)
|
|
(else 0)))))
|
|
(unless (char? char)
|
|
(error "Expected a char" char))
|
|
(cond
|
|
((char<=? #\0 char #\9) ;fast case
|
|
(- (char->integer char) (char->integer #\0)))
|
|
((vector-binary-search *decimal-zeroes* char cmp)
|
|
=> (lambda (zero)
|
|
(- (char->integer char)
|
|
(vector-ref *decimal-zeroes* zero))))
|
|
(else #f)))
|