mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 19:20:23 +02:00
44602b0868
* libguile/Makefile.am (lib_LTLIBRARIES): Instead of just "libguile.la", make "libguile-@EFFECTIVE_VERSION@.la". This allows multiple versions of Guile to be installed at once. See http://www106.pair.com/rhp/parallel.html for a rationale. (libguile_@GUILE_EFFECTIVE_VERSION@_la_CFLAGS): (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES): (libguile_@GUILE_EFFECTIVE_VERSION@_la_LIBADD): (libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS): Fixup automake vars to include the effective version. (guile_LDADD): Fix up the spelling of libguile. * libguile/bytevectors.c (scm_bootstrap_bytevectors): * libguile/foreign.c (scm_register_foreign): * libguile/i18n.c (scm_bootstrap_i18n): * libguile/instructions.c (scm_bootstrap_instructions): * libguile/objcodes.c (scm_bootstrap_objcodes): * libguile/programs.c (scm_bootstrap_programs): * libguile/vm.c (scm_bootstrap_vm): Register extensions using e.g. "libguile-2.0" as the libname -- i.e., including the effective version in the libname. * module/ice-9/i18n.scm: * module/rnrs/bytevector.scm: * module/rnrs/io/ports.scm: * module/system/foreign.scm: * module/system/vm/instruction.scm: * module/system/vm/objcode.scm: * module/system/vm/program.scm: * module/system/vm/vm.scm: When doing a load-extension for something in Guile, use the effective version also. * meta/guile-2.0-uninstalled.pc.in (Libs): * meta/guile-2.0.pc.in (Libs): Use -lguile-@EFFECTIVE_VERSION@. This change should mean that code built against Guile should not be affected by the libguile rename. * guile-readline/Makefile.am (libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD): * srfi/Makefile.am (libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD): (libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD): (libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD): (libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD): * test-suite/standalone/Makefile.am (test_num2integral_LDADD): (test_round_LDADD): (libtest_asmobs_la_LIBADD): (libtest_ffi_la_LIBADD): (test_list_LDADD): (test_unwind_LDADD): (test_conversion_LDADD): (test_loose_ends_LDADD): (test_scm_c_read_LDADD): (test_scm_take_locale_symbol_LDADD): (test_scm_take_u8vector_LDADD): (libtest_extensions_la_LIBADD): (test_with_guile_module_LDADD): (test_scm_with_guile_LDADD): Fix up the spelling of libguile.la.
418 lines
16 KiB
Scheme
418 lines
16 KiB
Scheme
;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*-
|
||
|
||
;;;; Copyright (C) 2006, 2007, 2009, 2010 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
|
||
|
||
;;; Author: Ludovic Courtès <ludo@gnu.org>
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides a number of routines that support
|
||
;;; internationalization (e.g., locale-dependent text collation, character
|
||
;;; mapping, etc.). It also defines `locale' objects, representing locale
|
||
;;; settings, that may be passed around to most of these procedures.
|
||
;;;
|
||
|
||
;;; Code:
|
||
|
||
(define-module (ice-9 i18n)
|
||
:use-module (ice-9 optargs)
|
||
:export (;; `locale' type
|
||
make-locale locale?
|
||
%global-locale
|
||
|
||
;; text collation
|
||
string-locale<? string-locale>?
|
||
string-locale-ci<? string-locale-ci>? string-locale-ci=?
|
||
|
||
char-locale<? char-locale>?
|
||
char-locale-ci<? char-locale-ci>? char-locale-ci=?
|
||
|
||
;; character mapping
|
||
char-locale-downcase char-locale-upcase char-locale-titlecase
|
||
string-locale-downcase string-locale-upcase string-locale-titlecase
|
||
|
||
;; reading numbers
|
||
locale-string->integer locale-string->inexact
|
||
|
||
;; charset/encoding
|
||
locale-encoding
|
||
|
||
;; days and months
|
||
locale-day-short locale-day locale-month-short locale-month
|
||
|
||
;; date and time
|
||
locale-am-string locale-pm-string
|
||
locale-date+time-format locale-date-format locale-time-format
|
||
locale-time+am/pm-format
|
||
locale-era locale-era-year
|
||
locale-era-date-format locale-era-date+time-format
|
||
locale-era-time-format
|
||
|
||
;; monetary
|
||
locale-currency-symbol
|
||
locale-monetary-decimal-point locale-monetary-thousands-separator
|
||
locale-monetary-grouping locale-monetary-fractional-digits
|
||
locale-currency-symbol-precedes-positive?
|
||
locale-currency-symbol-precedes-negative?
|
||
locale-positive-separated-by-space?
|
||
locale-negative-separated-by-space?
|
||
locale-monetary-positive-sign locale-monetary-negative-sign
|
||
locale-positive-sign-position locale-negative-sign-position
|
||
monetary-amount->locale-string
|
||
|
||
;; number formatting
|
||
locale-digit-grouping locale-decimal-point
|
||
locale-thousands-separator
|
||
number->locale-string
|
||
|
||
;; miscellaneous
|
||
locale-yes-regexp locale-no-regexp))
|
||
|
||
|
||
(eval-when (eval load compile)
|
||
(load-extension (string-append "libguile-" (effective-version))
|
||
"scm_init_i18n"))
|
||
|
||
|
||
;;;
|
||
;;; Charset/encoding.
|
||
;;;
|
||
|
||
(define (locale-encoding . locale)
|
||
(apply nl-langinfo CODESET locale))
|
||
|
||
|
||
;;;
|
||
;;; Months and days.
|
||
;;;
|
||
|
||
;; Helper macro: Define a procedure named NAME that maps its argument to
|
||
;; NL-ITEMS (when `nl-langinfo' is provided) or DEFAULTS (when `nl-langinfo'
|
||
;; is not provided).
|
||
(define-macro (define-vector-langinfo-mapping name nl-items defaults)
|
||
(let* ((item-count (length nl-items))
|
||
(defines (if (provided? 'nl-langinfo)
|
||
`(define %nl-items (vector #f ,@nl-items))
|
||
`(define %defaults (vector #f ,@defaults))))
|
||
(make-body (lambda (result)
|
||
`(if (and (integer? item) (exact? item))
|
||
(if (and (>= item 1) (<= item ,item-count))
|
||
,result
|
||
(throw 'out-of-range "out of range" item))
|
||
(throw 'wrong-type-arg "wrong argument type" item)))))
|
||
`(define (,name item . locale)
|
||
,defines
|
||
,(make-body (if (provided? 'nl-langinfo)
|
||
'(apply nl-langinfo (vector-ref %nl-items item) locale)
|
||
'(vector-ref %defaults item))))))
|
||
|
||
|
||
(define-vector-langinfo-mapping locale-day-short
|
||
(ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7)
|
||
("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
|
||
|
||
(define-vector-langinfo-mapping locale-day
|
||
(DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)
|
||
("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
|
||
|
||
(define-vector-langinfo-mapping locale-month-short
|
||
(ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
|
||
ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12)
|
||
("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
|
||
|
||
(define-vector-langinfo-mapping locale-month
|
||
(MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12)
|
||
("January" "February" "March" "April" "May" "June" "July" "August"
|
||
"September" "October" "November" "December"))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Date and time.
|
||
;;;
|
||
|
||
;; Helper macro: Define a procedure NAME that gets langinfo item ITEM.
|
||
(define-macro (define-simple-langinfo-mapping name item default)
|
||
(let ((body (if (and (provided? 'nl-langinfo) (defined? item))
|
||
`(apply nl-langinfo ,item locale)
|
||
default)))
|
||
`(define (,name . locale)
|
||
,body)))
|
||
|
||
(define-simple-langinfo-mapping locale-am-string
|
||
AM_STR "AM")
|
||
(define-simple-langinfo-mapping locale-pm-string
|
||
PM_STR "PM")
|
||
(define-simple-langinfo-mapping locale-date+time-format
|
||
D_T_FMT "%a %b %e %H:%M:%S %Y")
|
||
(define-simple-langinfo-mapping locale-date-format
|
||
D_FMT "%m/%d/%y")
|
||
(define-simple-langinfo-mapping locale-time-format
|
||
T_FMT "%H:%M:%S")
|
||
(define-simple-langinfo-mapping locale-time+am/pm-format
|
||
T_FMT_AMPM "%I:%M:%S %p")
|
||
(define-simple-langinfo-mapping locale-era
|
||
ERA "")
|
||
(define-simple-langinfo-mapping locale-era-year
|
||
ERA_YEAR "")
|
||
(define-simple-langinfo-mapping locale-era-date+time-format
|
||
ERA_D_T_FMT "")
|
||
(define-simple-langinfo-mapping locale-era-date-format
|
||
ERA_D_FMT "")
|
||
(define-simple-langinfo-mapping locale-era-time-format
|
||
ERA_T_FMT "")
|
||
|
||
|
||
|
||
;;;
|
||
;;; Monetary information.
|
||
;;;
|
||
|
||
(define-macro (define-monetary-langinfo-mapping name local-item intl-item
|
||
default/local default/intl)
|
||
(let ((body
|
||
(let ((intl (if (and (provided? 'nl-langinfo) (defined? intl-item))
|
||
`(apply nl-langinfo ,intl-item locale)
|
||
default/intl))
|
||
(local (if (and (provided? 'nl-langinfo) (defined? local-item))
|
||
`(apply nl-langinfo ,local-item locale)
|
||
default/local)))
|
||
`(if intl? ,intl ,local))))
|
||
|
||
`(define (,name intl? . locale)
|
||
,body)))
|
||
|
||
;; FIXME: How can we use ALT_DIGITS?
|
||
(define-monetary-langinfo-mapping locale-currency-symbol
|
||
CRNCYSTR INT_CURR_SYMBOL
|
||
"-" "")
|
||
(define-monetary-langinfo-mapping locale-monetary-fractional-digits
|
||
FRAC_DIGITS INT_FRAC_DIGITS
|
||
2 2)
|
||
|
||
(define-simple-langinfo-mapping locale-monetary-positive-sign
|
||
POSITIVE_SIGN "+")
|
||
(define-simple-langinfo-mapping locale-monetary-negative-sign
|
||
NEGATIVE_SIGN "-")
|
||
(define-simple-langinfo-mapping locale-monetary-decimal-point
|
||
MON_DECIMAL_POINT "")
|
||
(define-simple-langinfo-mapping locale-monetary-thousands-separator
|
||
MON_THOUSANDS_SEP "")
|
||
(define-simple-langinfo-mapping locale-monetary-digit-grouping
|
||
MON_GROUPING '())
|
||
|
||
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
|
||
P_CS_PRECEDES INT_P_CS_PRECEDES
|
||
#t #t)
|
||
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
|
||
N_CS_PRECEDES INT_N_CS_PRECEDES
|
||
#t #t)
|
||
|
||
|
||
(define-monetary-langinfo-mapping locale-positive-separated-by-space?
|
||
;; Whether a space should be inserted between a positive amount and the
|
||
;; currency symbol.
|
||
P_SEP_BY_SPACE INT_P_SEP_BY_SPACE
|
||
#t #t)
|
||
(define-monetary-langinfo-mapping locale-negative-separated-by-space?
|
||
;; Whether a space should be inserted between a negative amount and the
|
||
;; currency symbol.
|
||
N_SEP_BY_SPACE INT_N_SEP_BY_SPACE
|
||
#t #t)
|
||
|
||
(define-monetary-langinfo-mapping locale-positive-sign-position
|
||
;; Position of the positive sign wrt. currency symbol and quantity in a
|
||
;; monetary amount.
|
||
P_SIGN_POSN INT_P_SIGN_POSN
|
||
'unspecified 'unspecified)
|
||
(define-monetary-langinfo-mapping locale-negative-sign-position
|
||
;; Position of the negative sign wrt. currency symbol and quantity in a
|
||
;; monetary amount.
|
||
N_SIGN_POSN INT_N_SIGN_POSN
|
||
'unspecified 'unspecified)
|
||
|
||
|
||
(define (%number-integer-part int grouping separator)
|
||
;; Process INT (a string denoting a number's integer part) and return a new
|
||
;; string with digit grouping and separators according to GROUPING (a list,
|
||
;; potentially circular) and SEPARATOR (a string).
|
||
|
||
;; Process INT from right to left.
|
||
(let loop ((int int)
|
||
(grouping grouping)
|
||
(result '()))
|
||
(cond ((string=? int "") (apply string-append result))
|
||
((null? grouping) (apply string-append int result))
|
||
(else
|
||
(let* ((len (string-length int))
|
||
(cut (min (car grouping) len)))
|
||
(loop (substring int 0 (- len cut))
|
||
(cdr grouping)
|
||
(let ((sub (substring int (- len cut) len)))
|
||
(if (> len cut)
|
||
(cons* separator sub result)
|
||
(cons sub result)))))))))
|
||
|
||
(define (add-monetary-sign+currency amount figure intl? locale)
|
||
;; Add a sign and currency symbol around FIGURE. FIGURE should be a
|
||
;; formatted unsigned amount (a string) representing AMOUNT.
|
||
(let* ((positive? (> amount 0))
|
||
(sign
|
||
(cond ((> amount 0) (locale-monetary-positive-sign locale))
|
||
((< amount 0) (locale-monetary-negative-sign locale))
|
||
(else "")))
|
||
(currency (locale-currency-symbol intl? locale))
|
||
(currency-precedes?
|
||
(if positive?
|
||
locale-currency-symbol-precedes-positive?
|
||
locale-currency-symbol-precedes-negative?))
|
||
(separated?
|
||
(if positive?
|
||
locale-positive-separated-by-space?
|
||
locale-negative-separated-by-space?))
|
||
(sign-position
|
||
(if positive?
|
||
locale-positive-sign-position
|
||
locale-negative-sign-position))
|
||
(currency-space
|
||
(if (separated? intl? locale) " " ""))
|
||
(append-currency
|
||
(lambda (amt)
|
||
(if (currency-precedes? intl? locale)
|
||
(string-append currency currency-space amt)
|
||
(string-append amt currency-space currency)))))
|
||
|
||
(case (sign-position intl? locale)
|
||
((parenthesize)
|
||
(string-append "(" (append-currency figure) ")"))
|
||
((sign-before)
|
||
(string-append sign (append-currency figure)))
|
||
((sign-after unspecified)
|
||
;; following glibc's recommendation for `unspecified'.
|
||
(if (currency-precedes? intl? locale)
|
||
(string-append currency currency-space sign figure)
|
||
(string-append figure currency-space currency sign)))
|
||
((sign-before-currency-symbol)
|
||
(if (currency-precedes? intl? locale)
|
||
(string-append sign currency currency-space figure)
|
||
(string-append figure currency-space sign currency))) ;; unlikely
|
||
((sign-after-currency-symbol)
|
||
(if (currency-precedes? intl? locale)
|
||
(string-append currency sign currency-space figure)
|
||
(string-append figure currency-space currency sign)))
|
||
(else
|
||
(error "unsupported sign position" (sign-position intl? locale))))))
|
||
|
||
|
||
(define* (monetary-amount->locale-string amount intl?
|
||
#:optional (locale %global-locale))
|
||
"Convert @var{amount} (an inexact) into a string according to the cultural
|
||
conventions of either @var{locale} (a locale object) or the current locale.
|
||
If @var{intl?} is true, then the international monetary format for the given
|
||
locale is used."
|
||
|
||
(let* ((fraction-digits
|
||
(or (locale-monetary-fractional-digits intl? locale) 2))
|
||
(decimal-part
|
||
(lambda (dec)
|
||
(if (or (string=? dec "") (eq? 0 fraction-digits))
|
||
""
|
||
(string-append (locale-monetary-decimal-point locale)
|
||
(if (< fraction-digits (string-length dec))
|
||
(substring dec 0 fraction-digits)
|
||
dec)))))
|
||
|
||
(external-repr (number->string (if (> amount 0) amount (- amount))))
|
||
(int+dec (string-split external-repr #\.))
|
||
(int (car int+dec))
|
||
(dec (decimal-part (if (null? (cdr int+dec))
|
||
""
|
||
(cadr int+dec))))
|
||
(grouping (locale-monetary-digit-grouping locale))
|
||
(separator (locale-monetary-thousands-separator locale)))
|
||
|
||
(add-monetary-sign+currency amount
|
||
(string-append
|
||
(%number-integer-part int grouping
|
||
separator)
|
||
dec)
|
||
intl? locale)))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Number formatting.
|
||
;;;
|
||
|
||
(define-simple-langinfo-mapping locale-digit-grouping
|
||
GROUPING '())
|
||
(define-simple-langinfo-mapping locale-decimal-point
|
||
RADIXCHAR ".")
|
||
(define-simple-langinfo-mapping locale-thousands-separator
|
||
THOUSEP "")
|
||
|
||
(define* (number->locale-string number
|
||
#:optional (fraction-digits #t)
|
||
(locale %global-locale))
|
||
"Convert @var{number} (an inexact) into a string according to the cultural
|
||
conventions of either @var{locale} (a locale object) or the current locale.
|
||
Optionally, @var{fraction-digits} may be bound to an integer specifying the
|
||
number of fractional digits to be displayed."
|
||
|
||
(let* ((sign
|
||
(cond ((> number 0) "")
|
||
((< number 0) "-")
|
||
(else "")))
|
||
(decimal-part
|
||
(lambda (dec)
|
||
(if (or (string=? dec "") (eq? 0 fraction-digits))
|
||
""
|
||
(string-append (locale-decimal-point locale)
|
||
(if (and (integer? fraction-digits)
|
||
(< fraction-digits
|
||
(string-length dec)))
|
||
(substring dec 0 fraction-digits)
|
||
dec))))))
|
||
|
||
(let* ((external-repr (number->string (if (> number 0)
|
||
number
|
||
(- number))))
|
||
(int+dec (string-split external-repr #\.))
|
||
(int (car int+dec))
|
||
(dec (decimal-part (if (null? (cdr int+dec))
|
||
""
|
||
(cadr int+dec))))
|
||
(grouping (locale-digit-grouping locale))
|
||
(separator (locale-thousands-separator locale)))
|
||
|
||
(string-append sign
|
||
(%number-integer-part int grouping separator)
|
||
dec))))
|
||
|
||
|
||
;;;
|
||
;;; Miscellaneous.
|
||
;;;
|
||
|
||
(define-simple-langinfo-mapping locale-yes-regexp
|
||
YESEXPR "^[yY]")
|
||
(define-simple-langinfo-mapping locale-no-regexp
|
||
NOEXPR "^[nN]")
|
||
|
||
;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
|
||
|
||
;;; i18n.scm ends here
|