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@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@common-lisp.net> + * printers.lisp: Added formatter. + 2004-12-17 Sean Ross <sross@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@jhb.ucs.co.za>" :maintainer "Sean Ross <sdr@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