Update of /project/cl-l10n/cvsroot/cl-l10n
In directory common-lisp.net:/tmp/cvs-serv10150
Modified Files:
ChangeLog README cl-l10n.asd load-locale.lisp locale.lisp
package.lisp parse-number.lisp printers.lisp tests.lisp
utils.lisp
Log Message:
ChangeLog 2004-12-30
Date: Thu Dec 30 12:56:41 2004
Author: sross
Index: cl-l10n/ChangeLog
diff -u cl-l10n/ChangeLog:1.6 cl-l10n/ChangeLog:1.7
--- cl-l10n/ChangeLog:1.6 Fri Dec 17 11:06:43 2004
+++ cl-l10n/ChangeLog Thu Dec 30 12:56:38 2004
@@ -1,3 +1,11 @@
+2004-12-30 Sean Ross <sross(a)common-lisp.net>
+ * printers.lisp, load-locale.lisp: Changed format-number and
+ format-money to use a format string created at locale load time.
+ * locale.lisp: Cache Getter functions.
+
+2004-12-20 Sean Ross <sross(a)common-lisp.net>
+ * printers.lisp: Added formatter.
+
2004-12-17 Sean Ross <sross(a)common-lisp.net>
* printers.lisp: Fixed incorrect sign when printing
numbers and money.
Index: cl-l10n/README
diff -u cl-l10n/README:1.1 cl-l10n/README:1.2
--- cl-l10n/README:1.1 Tue Nov 30 11:05:07 2004
+++ cl-l10n/README Thu Dec 30 12:56:38 2004
@@ -8,7 +8,7 @@
cl-l10n is a localization package for common-lisp. It is meant
to be serve the same purpose as Allegro Common Lisp's
various locale functions. It currently runs on
-CMUCL, SBCL, CLISP and Lispworks although porting to a new
+CMUCL, SBCL, CLISP, ECL and Lispworks although porting to a new
implementation should be ridiculously trivial.
Index: cl-l10n/cl-l10n.asd
diff -u cl-l10n/cl-l10n.asd:1.6 cl-l10n/cl-l10n.asd:1.7
--- cl-l10n/cl-l10n.asd:1.6 Fri Dec 17 11:06:43 2004
+++ cl-l10n/cl-l10n.asd Thu Dec 30 12:56:38 2004
@@ -11,7 +11,7 @@
:name "CL-L10N"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.1.10"
+ :version "0.2.0"
:description "Portable CL Locale Support"
:long-description "Portable CL Package to support localization"
:licence "MIT"
@@ -19,10 +19,10 @@
(:file "parse-number" :depends-on ("package"))
(:file "utils" :depends-on ("package"))
(:file "locale" :depends-on ("utils"))
- (:file "printers" :depends-on ("locale"))
+ (:file "load-locale" :depends-on ("locale"))
+ (:file "printers" :depends-on ("load-locale"))
(:file "parsers" :depends-on ("printers" "parse-number"))
- (:file "i18n" :depends-on ("printers"))
- (:file "load-locale" :depends-on ("locale")))
+ (:file "i18n" :depends-on ("printers")))
:depends-on (:cl-ppcre))
(defmethod perform :after ((o load-op) (c (eql (find-system :cl-l10n))))
Index: cl-l10n/load-locale.lisp
diff -u cl-l10n/load-locale.lisp:1.6 cl-l10n/load-locale.lisp:1.7
--- cl-l10n/load-locale.lisp:1.6 Wed Dec 1 12:48:40 2004
+++ cl-l10n/load-locale.lisp Thu Dec 30 12:56:38 2004
@@ -9,6 +9,9 @@
(let ((name (aif (position #\. loc-name)
(subseq loc-name 0 it)
loc-name)))
+ (unless use-cache
+ ;; The local file might have changed so ...
+ (clear-getter-cache))
(acond ((and (not name) (not errorp)) nil)
((and use-cache (get-locale name)) it)
((probe-file (merge-pathnames *locale-path* name))
@@ -16,10 +19,18 @@
((not errorp) (warn "Can't find locale ~A." name))
(errorp (locale-error "Can't find locale ~A." name)))))
+(defvar *locale-type* 'locale)
+
+(defun locale-des->locale (loc)
+ (etypecase loc
+ (locale loc)
+ (string (locale loc))
+ (symbol (locale (string loc)))))
+
(defun load-locale (name)
(let ((path (merge-pathnames *locale-path* name)))
- (format t "~&;; Loading locale from ~A.~%" path)
- (let ((locale (make-instance 'locale :name name))
+ (cl:format t "~&;; Loading locale from ~A.~%" path)
+ (let ((locale (make-instance *locale-type* :name name))
(*read-eval* nil)
(*print-circle* nil))
(with-open-file (stream path
@@ -30,6 +41,7 @@
(awhen (make-category locale it (parse-category it stream
escape comment))
(setf (get-category (category-name it) locale) it)))))
+ (add-printers locale)
(setf (get-locale name) locale))))
(defun load-all-locales (&optional (*locale-path* *locale-path*))
@@ -39,6 +51,67 @@
(handler-case (load-locale (pathname-name x))
(locale-error (c) (warn "Unable to load locale ~A. ~%~A." x c)))))))
+
+(defun create-number-fmt-string (locale no-ts)
+ (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}" (schar (locale-thousands-sep locale) 0)
+ (locale-grouping locale)
+ (if no-ts "D" ":D")))
+
+(defun get-descriptors (minusp locale)
+ (if minusp
+ (values (locale-n-sep-by-space locale)
+ (= 1 (locale-n-cs-precedes locale))
+ (locale-n-sign-posn locale)
+ (locale-negative-sign locale))
+ (values (locale-p-sep-by-space locale)
+ (= 1 (locale-p-cs-precedes locale))
+ (locale-p-sign-posn locale)
+ (locale-positive-sign locale))))
+
+(defun create-money-fmt-string (locale no-ts minusp)
+ (multiple-value-bind (sep-by-space prec spos sign)
+ (get-descriptors minusp locale)
+ (let ((sym-sep (if (zerop sep-by-space) "" " ")))
+ (with-output-to-string (stream)
+ ;; sign and sign separator
+ (when (or* (= spos 0 1 3))
+ (princ (if (zerop spos) "(" sign) stream)
+ (when (= 2 sep-by-space)
+ (princ #\Space stream)))
+ ;; Sym and seperator
+ (princ "~A" stream)
+ (when prec
+ (princ sym-sep stream))
+ ;; Actual number
+ (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"
+ (schar (locale-mon-thousands-sep locale) 0)
+ (locale-mon-grouping locale)
+ (if no-ts "D" ":D"))
+ (unless prec
+ (princ sym-sep stream))
+ (princ "~A" stream)
+ (when (or* (= spos 0 2 4))
+ (when (= 2 sep-by-space)
+ (princ #\Space stream))
+ (princ (if (zerop spos) ")" sign) stream))))))
+
+(defun add-printers (locale)
+ (setf (printers locale)
+ (nconc (list :number-no-ts
+ (create-number-fmt-string locale t))
+ (list :number-ts
+ (create-number-fmt-string locale nil))
+ (list :money-p-no-ts
+ (create-money-fmt-string locale t nil))
+ (list :money-p-ts
+ (create-money-fmt-string locale nil nil))
+ (list :money-n-no-ts
+ (create-money-fmt-string locale t t))
+ (list :money-n-ts
+ (create-money-fmt-string locale nil t))
+ (printers locale))))
+
+
(defvar *category-loaders*
'(("LC_IDENTIFICATION" . load-identification)
("LC_MONETARY" . load-category)
@@ -61,11 +134,11 @@
(defun load-category (locale name vals)
(declare (ignore locale))
(let ((cat (make-instance 'category :name name)))
- (typecase vals
+ (etypecase vals
(category vals)
- (t (dolist (x vals)
- (setf (get-cat-val (car x) cat) (cdr x)))
- cat))))
+ (cons (dolist (x vals)
+ (setf (get-cat-val (car x) cat) (cdr x)))
+ cat))))
(defvar *id-vals*
'(("title" . title)
@@ -165,22 +238,24 @@
:everything)
#\>))
+(defvar *match-scanner* (cl-ppcre:create-scanner *regex*))
+
(defun old-real-value (val)
- (aif (all-matches-as-strings *regex* val)
+ (aif (all-matches-as-strings *match-scanner* val)
(map #-lispworks 'string #+lispworks
'lw:text-string #'real-character it)
val))
;; KLUDGE
(defun real-value (val)
- (let ((val (old-real-value val)))
- (if (string= val "\"\"")
- ""
- val)))
+ (remove #\" (old-real-value val)))
+(defvar *split-scanner*
+ (cl-ppcre:create-scanner '(:char-class #\;)))
+
(defun parse-value (val)
- (let ((all-vals (split '(:char-class #\;) val)))
+ (let ((all-vals (split *split-scanner* val)))
(if (singlep all-vals)
(real-value (car all-vals))
(mapcar #'real-value all-vals))))
@@ -201,9 +276,9 @@
(loop for line = (read-line stream nil stream)
until (eq line stream) do
(if (and (> (length line) 3) (search "LC_" line :end2 3)
- (not (some #'(lambda (x)
- (search x line :test #'string=))
- *ignore-categories*)))
+ (notany #'(lambda (x)
+ (search x line :test #'string=))
+ *ignore-categories*))
(return-from next-header line))))
(defun load-default-locale ()
Index: cl-l10n/locale.lisp
diff -u cl-l10n/locale.lisp:1.5 cl-l10n/locale.lisp:1.6
--- cl-l10n/locale.lisp:1.5 Wed Dec 8 11:02:23 2004
+++ cl-l10n/locale.lisp Thu Dec 30 12:56:38 2004
@@ -4,8 +4,9 @@
;; TODO
;; What to do with LC_CTYPE, LC_COLLATE
;; Test on windows.
-;; Parsers?
+;; Parsers (money and time)
;; locale aliases
+;; Optimizing print-time
(in-package :cl-l10n )
@@ -18,29 +19,29 @@
(append (pathname-directory path)
'("locales"))
:defaults #P"")))
-
(defvar *locale* nil)
-(defvar *locales* (make-hash-table :test #'equal))
+(defvar *locales* (make-hash-table :test #'equal)
+ "Hash table containing all loaded locales keyed on name (eg. \"af_ZA\")")
;; Conditions
(defun locale-report (obj stream)
- (format stream "~A" (mesg obj)))
+ (cl:format stream "~A" (mesg obj)))
(define-condition locale-error ()
((mesg :accessor mesg :initarg :mesg :initform "Unknown."))
(:report locale-report))
(defun locale-error (string &rest args)
- (error 'locale-error :mesg (apply #'format nil string args)))
-
+ (error 'locale-error :mesg (apply #'cl:format nil string args)))
;; Classes
(defclass locale ()
((locale-name :accessor locale-name :initarg :name
:initform (required-arg :name))
(title :accessor title :initarg :title :initform nil)
+ (printers :accessor printers :initarg :printers :initform nil)
(source :accessor source :initarg :source :initform nil)
(language :accessor language :initarg :language :initform nil)
(territory :accessor territory :initarg :territory :initform nil)
@@ -74,7 +75,6 @@
(defmacro get-cat-val (value cat)
`(gethash ,value (vals ,cat)))
-
(defun locale-value (locale cat key)
(awhen (get-category cat locale)
(get-cat-val key it)))
@@ -86,19 +86,26 @@
#+clisp (ext:getenv word)
#+ecl (si:getenv word))
-
;; Getters
+(let ((getter-cache (make-hash-table :test #'equal)))
+ (defun gett-value (locale cat key &optional (wrap #'identity))
+ (let ((lookup-key (list locale cat key)))
+ (multiple-value-bind (val win) (gethash lookup-key getter-cache)
+ (if (or val win)
+ val
+ (setf (gethash lookup-key getter-cache)
+ (funcall wrap (locale-value locale cat key)))))))
+ (defun clear-getter-cache ()
+ (setf getter-cache (make-hash-table :test #'equal))))
+
(defmacro defgetter (key cat &key wrap)
(let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
`(progn
- (defun ,name (&optional (locale *locale*))
- (let ((locale (locale-des->locale locale)))
- (when locale
- (awhen (get-category ,cat locale)
- ,(if wrap
- `(funcall ,wrap (get-cat-val ,key it))
- `(get-cat-val ,key it))))))
- (export ',name))))
+ (defun ,name (&optional (locale *locale*))
+ (let ((locale (locale-des->locale locale)))
+ (when locale
+ (gett-value locale ,cat ,key ,@(if wrap (list wrap) nil)))))
+ (export ',name))))
(defun parse-car-or-val (x)
(values (parse-integer (if (consp x) (car x) x))))
@@ -146,4 +153,4 @@
(defgetter "measurement" "LC_MEASUREMENT")
-;; EOF
\ No newline at end of file
+;; EOF
Index: cl-l10n/package.lisp
diff -u cl-l10n/package.lisp:1.3 cl-l10n/package.lisp:1.4
--- cl-l10n/package.lisp:1.3 Wed Dec 8 11:02:23 2004
+++ cl-l10n/package.lisp Thu Dec 30 12:56:38 2004
@@ -4,11 +4,11 @@
(defpackage #:cl-l10n
(:use #:cl #:cl-ppcre)
- (:shadow cl:format)
+ (:shadow cl:format cl:formatter)
(:export #:locale-name #:category-name #:locale #:category #:locale-error
#:get-category #:get-cat-val #:locale-value #:load-all-locales
#:*locale* #:*locale-path* #:*locales*
#:format-number #:print-number #:format-money #:print-money
#:format-time #:print-time #:add-resources #:bundle
- #:add-resource #:gettext #:parse-number))
+ #:add-resource #:gettext #:parse-number #:*float-digits*))
Index: cl-l10n/parse-number.lisp
diff -u cl-l10n/parse-number.lisp:1.2 cl-l10n/parse-number.lisp:1.3
--- cl-l10n/parse-number.lisp:1.2 Fri Dec 17 11:06:43 2004
+++ cl-l10n/parse-number.lisp Thu Dec 30 12:56:38 2004
@@ -40,8 +40,8 @@
:initarg :reason
:initform "Not specified"))
(:report (lambda (c s)
- (format s "Invalid number: ~S [Reason: ~A]"
- (value c) (reason c)))))
+ (cl:format s "Invalid number: ~S [Reason: ~A]"
+ (value c) (reason c)))))
(declaim (inline parse-integer-and-places))
(defun parse-integer-and-places (string start end &key (radix 10))
Index: cl-l10n/printers.lisp
diff -u cl-l10n/printers.lisp:1.6 cl-l10n/printers.lisp:1.7
--- cl-l10n/printers.lisp:1.6 Fri Dec 17 11:06:43 2004
+++ cl-l10n/printers.lisp Thu Dec 30 12:56:38 2004
@@ -2,64 +2,34 @@
;; See the file LICENCE for licence information.
(in-package :cl-l10n)
-;; Number and Money
-(defun digits-list (integer &optional (radix 10))
- (assert (>= integer 0))
- (loop collect (mod integer radix)
- while (> (setf integer (floor integer radix)) 0)))
-
-(defun print-int (stream sign int sep grouping)
- (let* ((digits (digits-list int))
- (fmt-string (mkstr "~A~{~{~A~}~^" sep "~}")))
- (format stream fmt-string
- sign (mapcar #'nreverse (nreverse (group digits grouping))))))
-
+;; Number
(defun get-sign (arg locale)
(cond ((plusp arg) (locale-positive-sign locale))
((minusp arg) (locale-negative-sign locale))
(t "")))
-(defun get-point (locale no-point float-part)
- (if (and (string= float-part "0") no-point)
- ""
- (locale-decimal-point locale)))
-
-(defun get-sep (locale no-sep)
- (if no-sep
- ""
- (locale-thousands-sep locale)))
-
-(defun locale-des->locale (loc)
- (etypecase loc
- (locale loc)
- (string (locale loc))
- (symbol (locale (string loc)))))
-
(defvar *float-digits* 2
"Used when all values after the decimal point are zero to
determine the number of zero's to print")
+(defun fix-float-string (string size)
+ (if (string= string "")
+ (make-string size :initial-element #\0)
+ string))
+
(defun format-number (stream arg no-dp no-ts
&optional (locale *locale*))
- (let ((locale (locale-des->locale locale)))
- (multiple-value-bind (int-part float-part) (split-float (abs (float arg)))
- (let* ((sign (get-sign arg locale))
- (point (get-point locale no-dp float-part))
- (float-part (if (every #'(lambda (x)
- (zerop (or (digit-char-p x) 1)))
- float-part)
- (make-string *float-digits*
- :initial-element #\0)
- float-part))
- (sep (get-sep locale no-ts))
- (grouping (locale-grouping locale)))
- (print-int stream sign int-part sep grouping)
- (unless (and (every #'(lambda (x)
- (zerop (or (digit-char-p x) 1)))
- float-part)
- no-dp)
- (princ point stream)
- (princ float-part stream))))))
+ (let ((locale (locale-des->locale locale))
+ (float-part (float-part (coerce (abs arg) 'double-float))))
+ (cl:format stream
+ (getf (printers locale)
+ (if no-ts :number-no-ts :number-ts))
+ (get-sign arg locale)
+ (truncate (abs arg))
+ (unless (and (string= "" float-part) no-dp)
+ (list (locale-decimal-point locale)
+ (fix-float-string float-part *float-digits*))))
+ (values)))
(defun print-number (number &key (stream *standard-output*)
no-ts no-dp (locale *locale*))
@@ -67,64 +37,49 @@
(format-number stream number no-dp no-ts locale)
number))
-(defun get-float-part (float locale use-int-sym)
- (let ((size (if use-int-sym
- (locale-int-frac-digits locale)
- (locale-frac-digits locale)))
- (len (length float)))
- (cond ((>= len size)
- (subseq float 0 size))
- ((< len size)
- (with-output-to-string (x)
- (princ float x)
- (dotimes (z (- size len))
- (princ 0 x))))
- (t float))))
-
-(defun get-descriptors (val locale)
- (if (minusp val)
- (values (locale-n-sep-by-space locale)
- (= 1 (locale-n-cs-precedes locale))
- (locale-n-sign-posn locale))
- (values (locale-p-sep-by-space locale)
- (= 1 (locale-p-cs-precedes locale))
- (locale-p-sign-posn locale))))
-;; FIXME . Rounding and float coercion.
+;; Money
+(defvar *default-round-mode* :round)
+
+(defun round-money (float frac-digits &key (round-mode *default-round-mode*))
+ (let ((round-fn (ecase round-mode
+ (:round #'fround)
+ (:down #'ffloor)
+ (:up #'fceiling))))
+ (let ((size (expt 10 frac-digits)))
+ (/ (funcall round-fn (* float size)) size))))
+
+(defun get-money-printer (minusp no-ts)
+ (if minusp
+ (if no-ts
+ :money-n-no-ts
+ :money-n-ts)
+ (if no-ts
+ :money-p-no-ts
+ :money-p-ts)))
+
(defun format-money (stream arg use-int-sym no-ts &optional (locale *locale*))
- (let ((locale (locale-des->locale locale)))
- (multiple-value-bind (int-part float-part)
- (split-float (abs (float arg 1.0d0)))
- (multiple-value-bind (sep-by-space prec spos)
- (get-descriptors arg locale)
- (let* ((sign (get-sign arg locale))
- (float-part (get-float-part float-part locale use-int-sym))
- (point (locale-mon-decimal-point locale))
- (sep (if no-ts "" (locale-mon-thousands-sep locale)))
- (grouping (locale-mon-grouping locale))
- (sym (if use-int-sym
- (locale-int-curr-symbol locale)
- (locale-currency-symbol locale)))
- (sym-sep (if (zerop sep-by-space) "" " ")))
-
- (when (or* (= spos 0 1 3))
- (princ (if (zerop spos) "(" sign) stream)
- (when (= 2 sep-by-space)
- (print #\Space stream)))
-
- (when prec
- (format stream "~A~A" sym sym-sep))
-
- (print-int stream "" int-part sep grouping)
- (unless (or* (string= float-part "" "0"))
- (princ point stream)
- (princ float-part stream))
- (unless prec
- (format stream "~A~A" sym-sep (trim sym)))
- (when (or* (= spos 0 2 4))
- (when (= 2 sep-by-space)
- (print #\Space stream))
- (princ (if (zerop spos) ")" sign) stream)))))))
+ (let* ((locale (locale-des->locale locale))
+ (frac-digits (if use-int-sym
+ (locale-int-frac-digits locale)
+ (locale-frac-digits locale)))
+ (val-to-print (round-money (abs (coerce arg 'double-float))
+ frac-digits))
+ (float-part (float-part (coerce val-to-print 'float)))
+ (sym (if use-int-sym
+ (locale-int-curr-symbol locale)
+ (locale-currency-symbol locale)))
+ (prec (= 1 (locale-n-cs-precedes locale))))
+ (cl:format stream
+ (getf (printers locale)
+ (get-money-printer (minusp arg) no-ts))
+ (if prec sym "")
+ (truncate (abs val-to-print))
+ (unless (zerop frac-digits)
+ (list (locale-mon-decimal-point locale)
+ (fix-float-string float-part frac-digits)))
+ (if prec "" (trim sym))))
+ (values))
(defun print-money (num &key (stream *standard-output*) use-int-sym no-ts
(locale *locale*))
@@ -132,8 +87,7 @@
(format-money stream num use-int-sym no-ts locale)
num))
-
-;; Time and date printing.
+;; ;; Time and date printing.
(defun get-time-fmt-string (locale show-date show-time)
(cond ((and show-time show-date)
(locale-d-t-fmt locale))
@@ -144,9 +98,10 @@
(show-time (locale-t-fmt locale))
(show-date (locale-d-fmt locale))))
-
(defvar *time-formatters* (make-hash-table))
(defmacro def-formatter (sym &body body)
+ "Creates a function with body which can be looked up using lookup-formatter
+ using the character SYM."
(let ((name (gensym (mkstr "FORMATTER-" sym))))
`(flet ((,name (stream locale ut sec min hour date month year day
daylight-p zone)
@@ -161,11 +116,13 @@
it
(locale-error "No format directive for char ~S." char)))
-(defun pad-val (val &optional (pad "0"))
- (if (< val 10)
- (format nil "~A~A" pad val)
- val))
-
+(defun princ-pad-val (val stream &optional (pad "0"))
+ (declare (type stream stream) (optimize speed)
+ (type fixnum val))
+ (when (< val 10)
+ (princ pad stream))
+ (princ val stream))
+
(defun last-2-digits (val)
(mod val 100))
@@ -181,27 +138,27 @@
(def-formatter #\b
- (format stream "~:(~A~)" (nth (1- month) (locale-abmon locale))))
-
+ (cl:format stream (cl:formatter "~:(~A~)")
+ (nth (1- month) (locale-abmon locale))))
(def-formatter #\B
- (format stream "~:(~A~)"
+ (cl:format stream (cl:formatter "~:(~A~)")
(nth (1- month) (locale-mon locale))))
(def-formatter #\c
(print-time-string "%a %b %d %T %Z %Y" stream ut locale))
(def-formatter #\C
- (princ (pad-val (truncate (/ year 100))) stream))
+ (princ-pad-val (truncate (/ year 100)) stream))
(def-formatter #\d
- (princ (pad-val date) stream))
+ (princ-pad-val date stream))
(def-formatter #\D
(print-time-string "%m/%d/%y" stream ut locale))
(def-formatter #\e
- (princ (pad-val month " ") stream))
+ (princ-pad-val month stream " "))
(def-formatter #\F
(print-time-string "%Y-%m-%d" stream ut locale))
@@ -217,11 +174,10 @@
stream))
(def-formatter #\H
- (princ (pad-val hour) stream))
+ (princ-pad-val hour stream))
(def-formatter #\I
- (princ (pad-val (if (> hour 12) (- hour 12) hour))
- stream))
+ (princ-pad-val (if (> hour 12) (- hour 12) hour) stream))
(defvar *mon-days*
'(31 28 31 30 31 30 31 31 30 31 30 31))
@@ -240,25 +196,23 @@
(loop repeat (1- month)
for x in (if (leap-year-p year) *mon-days-leap* *mon-days*) do
(incf total x))
- (incf total date)
- total))
+ (incf total date)))
(def-formatter #\j
(princ (day-of-year date month year) stream))
(def-formatter #\k
- (princ (pad-val hour " ") stream))
+ (princ-pad-val hour stream " "))
(def-formatter #\l
- (princ (pad-val (if (> hour 12) (- hour 12) hour)
- " ")
- stream))
+ (princ-pad-val (if (> hour 12) (- hour 12) hour) stream
+ " "))
(def-formatter #\m
- (princ (pad-val month) stream))
+ (princ-pad-val month stream))
(def-formatter #\M
- (princ (pad-val min) stream))
+ (princ-pad-val min stream))
(def-formatter #\n
(princ #\Newline stream))
@@ -290,7 +244,7 @@
(princ (- ut *1970-01-01*) stream))
(def-formatter #\S
- (princ (pad-val sec) stream))
+ (princ-pad-val sec stream))
(def-formatter #\t
(princ #\Tab stream))
@@ -327,7 +281,7 @@
(print-time-string "%R:%S" stream ut locale))
(def-formatter #\y
- (princ (pad-val (last-2-digits year)) stream))
+ (princ-pad-val (last-2-digits year) stream))
(def-formatter #\Y
(princ year stream))
@@ -336,7 +290,7 @@
(let ((d-zone (if daylight-p (1- zone) zone)))
(multiple-value-bind (hr mn) (truncate (abs d-zone))
(princ (if (minusp d-zone) #\+ #\-) stream)
- (format stream "~2,'0D~2,'0D"
+ (cl:format stream (cl:formatter "~2,'0D~2,'0D")
hr (floor (* 60 mn))))))
;; FIXME should be printing SAST rather than +0200
@@ -349,9 +303,11 @@
(let ((locale (locale-des->locale (or locale *locale*))))
(print-time-string (or fmt (get-time-fmt-string locale
show-date show-time))
- stream ut locale)))
+ stream ut locale))
+ (values))
(defun print-time-string (fmt-string stream ut locale)
+ (declare (optimize speed) (type simple-string fmt-string))
(let ((values (multiple-value-list (decode-universal-time ut))))
(loop for x across fmt-string
with perc = nil do
@@ -360,7 +316,8 @@
(progn (princ #\% stream) (setf perc nil))
(setf perc t)))
(t (if perc
- (progn (apply (lookup-formatter x) stream locale ut values)
+ (progn (apply (the function (lookup-formatter x))
+ stream locale ut values)
(setf perc nil))
(princ x stream)))))))
@@ -372,6 +329,9 @@
;; Format
+(defmacro formatter (fmt-string)
+ (etypecase fmt-string
+ (string `(cl:formatter ,(parse-fmt-string fmt-string)))))
(defun format (stream fmt-cntrl &rest args)
(apply #'cl:format stream
@@ -380,10 +340,18 @@
(string (parse-fmt-string fmt-cntrl)))
args))
+(defvar *scanner* (cl-ppcre:create-scanner "~[@v,:]*[m|u|n|M|U|N]"))
+
(defun parse-fmt-string (string)
+ (if (cl-ppcre:scan *scanner* string)
+ (really-parse-fmt-string string)
+ string))
+
+(defun really-parse-fmt-string (string)
+ (declare (optimize speed) (type string string))
(with-output-to-string (fmt-string)
(loop for char across string
- with tilde = nil do
+ with tilde = nil do
(case char
((#\@ #\v #\, #\:) (princ char fmt-string))
(#\~ (princ char fmt-string)
@@ -391,9 +359,10 @@
(setf tilde nil)
(setf tilde t)))
(t (if tilde
- (progn (setf tilde nil) (princ (get-replacement char) fmt-string))
+ (progn (setf tilde nil)
+ (princ (get-replacement char) fmt-string))
(princ char fmt-string)))))))
-
+
(defvar *directive-replacements*
'((#\M . "/cl-l10n:format-money/")
(#\U . "/cl-l10n:format-time/")
Index: cl-l10n/tests.lisp
diff -u cl-l10n/tests.lisp:1.3 cl-l10n/tests.lisp:1.4
--- cl-l10n/tests.lisp:1.3 Fri Dec 17 11:06:43 2004
+++ cl-l10n/tests.lisp Thu Dec 30 12:56:38 2004
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;; See the file LICENCE for licence information.
(defpackage :cl-l10n-tests
- (:shadowing-import-from :cl-l10n format)
+ (:shadowing-import-from :cl-l10n format formatter)
(:use :cl :regression-test :cl-l10n))
(in-package :cl-l10n-tests)
@@ -144,6 +144,19 @@
(deftest format.3
(format nil "~v:@m" "sv_SE" 1000)
+ "1000,00 SEK")
+
+;; formatter
+(deftest formatter.1
+ (format nil (formatter "~v:@U") "en_ZA" 3091103120)
+ "Sun 14 Dec 1997 17:45:20 +0200")
+
+(deftest formatter.2
+ (format nil (formatter "~v:n") "en_ZA" 1000)
+ "1,000")
+
+(deftest formatter.3
+ (format nil (formatter "~v:@m") "sv_SE" 1000)
"1000,00 SEK")
Index: cl-l10n/utils.lisp
diff -u cl-l10n/utils.lisp:1.4 cl-l10n/utils.lisp:1.5
--- cl-l10n/utils.lisp:1.4 Tue Dec 7 10:21:55 2004
+++ cl-l10n/utils.lisp Thu Dec 30 12:56:38 2004
@@ -84,8 +84,6 @@
(nreverse (cons source acc))))))
(if list (rec list nil) nil)))
-
-
(defun winner (test get seq)
(if (null seq)
nil
@@ -108,37 +106,22 @@
:initial-value (apply last-fn args))))
#'identity))
+(defun float-part (float)
+ (if (zerop float)
+ ""
+ (multiple-value-call 'extract-float-part (flonum-to-digits float))))
-(defun get-first (fore aft)
- (if (< fore 1)
- "0"
- (with-output-to-string (x)
- (let ((length (length aft)))
- (cond ((> fore length)
- (princ aft x)
- (dotimes (z (- fore length))
- (princ 0 x)))
- (t (princ (subseq aft 0 fore)
- x)))))))
-
-(defun get-second (fore aft)
+(defun extract-float-part (dp-pos aft)
(let ((length (length aft)))
- (if (> fore length)
- "0"
+ (if (> dp-pos length)
+ ""
(with-output-to-string (x)
- (cond ((minusp fore)
- (dotimes (z (abs fore))
+ (cond ((minusp dp-pos)
+ (dotimes (z (abs dp-pos))
(princ 0 x))
(princ aft x))
- (t (princ (subseq aft fore)
+ (t (princ (subseq aft dp-pos)
x)))))))
-
-(defun split-float (float)
- (multiple-value-bind (fore aft) (flonum-to-digits float)
- (values (parse-integer (get-first fore aft))
- (let ((val (get-second fore aft)))
- (if (string= val "") "0" val)))))
-
;; From sbcl sources (src/code/print.lisp)
(defconstant single-float-min-e
