diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 1326a2a02..2363ba350 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -246,6 +246,36 @@ 'unspecified 'unspecified) +(define (integer->string number) + "Return a string representing NUMBER, an integer, written in base 10." + (define (digit->char digit) + (integer->char (+ digit (char->integer #\0)))) + + (if (zero? number) + "0" + (let loop ((number number) + (digits '())) + (if (zero? number) + (list->string digits) + (loop (quotient number 10) + (cons (digit->char (modulo number 10)) + digits)))))) + +(define (number-decimal-string number digit-count) + "Return a string representing the decimal part of NUMBER, with exactly +DIGIT-COUNT digits" + (if (integer? number) + (make-string digit-count #\0) + + ;; XXX: This is brute-force and could be improved by following one + ;; of the "Printing Floating-Point Numbers Quickly and Accurately" + ;; papers. + (let ((number (* (expt 10 digit-count) + (- number (floor number))))) + (string-pad (integer->string (round (inexact->exact number))) + digit-count + #\0)))) + (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, @@ -336,12 +366,11 @@ locale is used." (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)))) + (int (integer->string (inexact->exact + (floor (abs amount))))) + (dec (decimal-part + (number-decimal-string (abs amount) + fraction-digits))) (grouping (locale-monetary-digit-grouping locale)) (separator (locale-monetary-thousands-separator locale))) @@ -388,14 +417,14 @@ number of fractional digits to be displayed." (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)))) + (let* ((int (integer->string (inexact->exact + (floor (abs number))))) + (dec (decimal-part + (number-decimal-string (abs number) + (if (integer? + fraction-digits) + fraction-digits + 0)))) (grouping (locale-digit-grouping locale)) (separator (locale-thousands-separator locale))) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index cc31942cc..9acbbcc22 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -2,7 +2,7 @@ ;;;; Matthias Koeppe --- June 2001 ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010, 2011, 2012, -;;;; 2014 Free Software Foundation, Inc. +;;;; 2014, 2017 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 @@ -124,22 +124,22 @@ (with-test-prefix "~h localized number" (pass-if "1234.5" - (string=? (format #f "~h" 1234.5) "1234.5")) + (string=? (format #f "~,1h" 1234.5) "1234.5")) (pass-if "padding" - (string=? (format #f "~6h" 123.2) " 123.2")) + (string=? (format #f "~6h" 123.2) " 123")) (pass-if "padchar" - (string=? (format #f "~8,,'*h" 123.2) "***123.2")) + (string=? (format #f "~8,1,'*h" 123.2) "***123.2")) (pass-if "decimals" (string=? (format #f "~,2h" 123.4567) - "123.45")) + "123.46")) (pass-if "locale" (string=? (format #f "~,3:h, ~a" 1234.5678 %global-locale "approximately") - "1234.567, approximately"))) + "1234.568, approximately"))) ;;; ;;; ~{ diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 3ce2b15cb..db7fa65e2 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -506,12 +506,20 @@ (pass-if-equal "fraction" "1234.567" - (number->locale-string 1234.567)) + (number->locale-string 1234.567 3)) (pass-if-equal "fraction, 1 digit" - "1234.5" + "1234.6" (number->locale-string 1234.567 1)) + (pass-if-equal "fraction, 10 digits" + "0.0000300000" + (number->locale-string .00003 10)) + + (pass-if-equal "trailing zeros" + "-10.00000" + (number->locale-string -10.0 5)) + (pass-if-equal "positive inexact zero, 1 digit" "0.0" (number->locale-string .0 1))) @@ -525,15 +533,22 @@ (let ((fr (make-locale LC_ALL %french-locale-name))) (number->locale-string 123456 #t fr))))) + (pass-if-equal "negative integer" + "-1 234 567" + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (number->locale-string -1234567 #t fr))))) + (pass-if-equal "fraction" "1 234,567" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 #t fr))))) + (number->locale-string 1234.567 3 fr))))) (pass-if-equal "fraction, 1 digit" - "1 234,5" + "1 234,6" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) @@ -553,7 +568,7 @@ (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (format #f "~:h" 12345.6789 %french-locale)))))) + (format #f "~,4:h" 12345.6789 %french-locale)))))) (with-test-prefix "English" @@ -563,7 +578,7 @@ (lambda () (if (null? (locale-digit-grouping %american-english-locale)) (throw 'unresolved) - (format #f "~:h" 12345.6789 + (format #f "~,4:h" 12345.6789 %american-english-locale))))))) (with-test-prefix "monetary-amount->locale-string" @@ -571,22 +586,36 @@ (with-test-prefix "French" (pass-if-equal "integer" - "123 456 +EUR" + "123 456,00 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string 123456 #f fr))))) (pass-if-equal "fraction" - "1 234,56 EUR " + "1 234,57 EUR " (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string 1234.567 #t fr))))) (pass-if-equal "positive inexact zero" - "0,0 +EUR" + "0,00 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 0. #f fr))))))) + (monetary-amount->locale-string 0. #f fr))))) + + (pass-if-equal "one cent" + "0,01 EUR " + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (monetary-amount->locale-string .01 #t fr))))) + + (pass-if-equal "very little money" + "0,00 EUR " + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (monetary-amount->locale-string .00003 #t fr)))))))