/[cmucl]/src/code/intl.lisp
ViewVC logotype

Diff of /src/code/intl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by rtoy, Mon Feb 8 02:49:49 2010 UTC revision 1.1.2.3 by rtoy, Mon Feb 8 23:43:17 2010 UTC
# Line 0  Line 1 
1    ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
2    
3    ;;; $Revision$
4    ;;; Copyright 1999-2010 Paul Foley (mycroft@actrix.gen.nz)
5    ;;;
6    ;;; Permission is hereby granted, free of charge, to any person obtaining
7    ;;; a copy of this Software to deal in the Software without restriction,
8    ;;; including without limitation the rights to use, copy, modify, merge,
9    ;;; publish, distribute, sublicense, and/or sell copies of the Software,
10    ;;; and to permit persons to whom the Software is furnished to do so,
11    ;;; provided that the above copyright notice and this permission notice
12    ;;; are included in all copies or substantial portions of the Software.
13    ;;;
14    ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
15    ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
16    ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17    ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
18    ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
19    ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
20    ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
21    ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
22    ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23    ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
24    ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
25    ;;; DAMAGE.
26    (ext:file-comment "$Header$")
27    
28    (in-package "INTL")
29    
30    (eval-when (:compile-toplevel :execute)
31      (defparameter intl::*default-domain* "cmucl")
32      (unless (and (fboundp 'intl:read-translatable-string)
33                   (eq (get-macro-character #\_)
34                       (fdefinition 'intl:read-translatable-string)))
35        (set-macro-character #\_ (lambda (stream char)
36                                   (declare (ignore char))
37                                   (case (peek-char nil stream nil nil t)
38                                     (#\" (values))
39                                     (#\N (read-char stream t nil t) (values))
40                                     (otherwise '_)))
41                             t)))
42    
43    (in-package "INTL")
44    
45    (defvar *locale-directories*
46      '(#p"library:locale/" #p"/usr/share/locale/" #p"target:i18n/locale/"))
47    (defvar *locale* "C")
48    
49    (defvar *default-domain* nil
50      _N"The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT.
51      Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.")
52    (defvar *loaded-domains* (make-hash-table :test 'equal))
53    (defvar *locale-aliases* (make-hash-table :test 'equal))
54    
55    (defstruct domain-entry
56      (domain "" :type simple-base-string)
57      (locale "" :type simple-base-string)
58      (file #p"" :type pathname)
59      (plurals nil :type (or null function))
60      (hash (make-hash-table :test 'equal) :type hash-table)
61      (encoding nil)
62      (readfn #'identity :type function))
63    
64    (declaim (ftype (function (stream) (unsigned-byte 32)) read-lelong))
65    (defun read-lelong (stream)
66      (declare (optimize (speed 3) (space 2) (safety 0)
67                         #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn
68      (+ (the (unsigned-byte 8) (read-byte stream))
69         (ash (the (unsigned-byte 8) (read-byte stream)) 8)
70         (ash (the (unsigned-byte 8) (read-byte stream)) 16)
71         (ash (the (unsigned-byte 8) (read-byte stream)) 24)))
72    
73    (declaim (ftype (function (stream) (unsigned-byte 32)) read-belong))
74    (defun read-belong (stream)
75      (declare (optimize (speed 3) (space 2) (safety 0)
76                         #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn
77      (+ (ash (the (unsigned-byte 8) (read-byte stream)) 24)
78         (ash (the (unsigned-byte 8) (read-byte stream)) 16)
79         (ash (the (unsigned-byte 8) (read-byte stream)) 8)
80         (the (unsigned-byte 8) (read-byte stream))))
81    
82    (defun locate-domain-file (domain locale locale-dir)
83      (flet ((path (locale base)
84               (merge-pathnames (make-pathname :directory (list :relative locale
85                                                                "LC_MESSAGES")
86                                               :name domain :type "mo")
87                                base)))
88        (let ((locale (or (gethash locale *locale-aliases*) locale)))
89          (dolist (base (if (listp locale-dir) locale-dir (list locale-dir)))
90            (let ((probe
91                   (or (probe-file (path locale base))
92                       (let ((dot (position #\. locale)))
93                         (and dot (probe-file (path (subseq locale 0 dot) base))))
94                       (let ((at (position #\@ locale)))
95                         (and at (probe-file (path (subseq locale 0 at) base))))
96                       (let ((us (position #\_ locale)))
97                         (and us (probe-file (path (subseq locale 0 us) base)))))))
98              (when probe (return probe)))))))
99    
100    (defun find-encoding (domain)
101      (when (null (domain-entry-encoding domain))
102        (setf (domain-entry-encoding domain) :iso-8859-1)
103        (let* ((header (domain-lookup "" domain))
104               (ctype (search "Content-Type: " header))
105               (eoln (and ctype (position #\Newline header :start ctype)))
106               (charset (and ctype (search "; charset=" header
107                                           :start2 ctype :end2 eoln))))
108          (when charset
109            (incf charset 10)
110            (loop for i upfrom charset below eoln as c = (char header i)
111                while (or (alphanumericp c) (eql c #\-))
112              finally (setf (domain-entry-encoding domain)
113                          (intern (nstring-upcase (subseq header charset i))
114                                  "KEYWORD"))))))
115      domain)
116    
117    (defun parse-plurals (domain)
118      (let* ((header (domain-lookup "" domain))
119             (plurals (search "Plural-Forms: " header))
120             (default (lambda (n) (if (= n 1) 0 1))))
121        (if (and plurals
122                 (> (length header) (+ plurals 36))
123                 (string= header "nplurals="
124                          :start1 (+ plurals 14) :end1 (+ plurals 23)))
125            (let ((nplurals
126                   (parse-integer header :start (+ plurals 23) :junk-allowed t))
127                  (point (+ (position #\; header :start (+ plurals 23)) 2)))
128              (if (and (> (length header) (+ point 10))
129                       (string= header "plural=" :start1 point :end1 (+ point 7)))
130                  (values (parse-expr header (+ point 7)) nplurals)
131                  (values default 2)))
132            (values default 2))))
133    
134    (defun parse-expr (string pos)
135      (labels ((next ()
136                 (loop while (member (char string pos) '(#\Space #\Tab #\Newline))
137                       do (incf pos))
138                 (case (char string (1- (incf pos)))
139                   (#\n 'n)
140                   (#\? 'IF)
141                   (#\: 'THEN)
142                   (#\( 'LPAR)
143                   (#\) 'RPAR)
144                   (#\^ 'LOGXOR)
145                   (#\+ 'ADD)
146                   (#\- 'SUB)
147                   (#\* 'MUL)
148                   (#\/ 'FLOOR)
149                   (#\% 'MOD)
150                   (#\~ 'LOGNOT32)
151                   (#\; 'END)
152                   (#\| (if (char= (char string pos) #\|)
153                            (progn (incf pos) 'COR)
154                            'LOGIOR))
155                   (#\& (if (char= (char string pos) #\&)
156                            (progn (incf pos) 'CAND)
157                            'LOGAND))
158                   (#\= (if (char= (char string pos) #\=)
159                            (progn (incf pos) 'CMP=)
160                            (error _"Encountered illegal token: =")))
161                   (#\! (if (char= (char string pos) #\=)
162                            (progn (incf pos) 'CMP/=)
163                            'NOT))
164                   (#\< (case (char string pos)
165                          (#\= (incf pos) 'CMP<=)
166                          (#\< (incf pos) 'SHL)
167                          (otherwise 'CMP<)))
168                   (#\> (case (char string pos)
169                          (#\= (incf pos) 'CMP>=)
170                          (#\> (incf pos) 'SHR)
171                          (otherwise 'CMP>)))
172                   (otherwise (let ((n (digit-char-p (char string (1- pos)))))
173                                (if n
174                                    (loop for nx = (digit-char-p (char string pos))
175                                          while nx
176                                       do (setq n (+ (* n 10) nx)) (incf pos)
177                                       finally (return n))
178                                    (error _"Encountered illegal token: ~C"
179                                           (char string (1- pos))))))))
180               (conditional (tok &aux tree)
181                 (multiple-value-setq (tree tok) (logical-or tok))
182                 (when (eql tok 'IF)
183                   (multiple-value-bind (right next) (logical-or (next))
184                     (unless (eql next 'THEN)
185                       (error _"Expected : in ?: construct"))
186                     (multiple-value-bind (else next) (conditional (next))
187                       (setq tree (list tok (list 'zerop tree) else right)
188                             tok next))))
189                 (values tree tok))
190               (logical-or (tok &aux tree)
191                 (multiple-value-setq (tree tok) (logical-and tok))
192                 (loop while (eql tok 'COR) do
193                    (multiple-value-bind (right next) (logical-and (next))
194                      (setq tree (list tok tree right)
195                            tok next)))
196                 (values tree tok))
197               (logical-and (tok &aux tree)
198                 (multiple-value-setq (tree tok) (inclusive-or tok))
199                 (loop while (eql tok 'CAND) do
200                    (multiple-value-bind (right next) (inclusive-or (next))
201                      (setq tree (list tok tree right)
202                            tok next)))
203                 (values tree tok))
204               (inclusive-or (tok &aux tree)
205                 (multiple-value-setq (tree tok) (exclusive-or tok))
206                 (loop while (eql tok 'LOGIOR) do
207                    (multiple-value-bind (right next) (exclusive-or (next))
208                      (setq tree (list tok tree right)
209                            tok next)))
210                 (values tree tok))
211               (exclusive-or (tok &aux tree)
212                 (multiple-value-setq (tree tok) (bitwise-and tok))
213                 (loop while (eql tok 'LOGXOR) do
214                    (multiple-value-bind (right next) (bitwise-and (next))
215                      (setq tree (list tok tree right)
216                            tok next)))
217                 (values tree tok))
218               (bitwise-and (tok &aux tree)
219                 (multiple-value-setq (tree tok) (equality tok))
220                 (loop while (eql tok 'LOGAND) do
221                    (multiple-value-bind (right next) (equality (next))
222                      (setq tree (list tok tree right)
223                            tok next)))
224                 (values tree tok))
225               (equality (tok &aux tree)
226                 (multiple-value-setq (tree tok) (relational tok))
227                 (loop while (member tok '(CMP= CMP/=)) do
228                    (multiple-value-bind (right next) (relational (next))
229                      (setq tree (list tok tree right)
230                            tok next)))
231                 (values tree tok))
232               (relational (tok &aux tree)
233                 (multiple-value-setq (tree tok) (shift tok))
234                 (loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do
235                    (multiple-value-bind (right next) (shift (next))
236                      (setq tree (list tok tree right)
237                            tok next)))
238                 (values tree tok))
239               (shift (tok &aux tree)
240                 (multiple-value-setq (tree tok) (additive tok))
241                 (loop while (member tok '(SHL SHR)) do
242                    (multiple-value-bind (right next) (additive (next))
243                      (setq tree (list tok tree right)
244                            tok next)))
245                 (values tree tok))
246               (additive (tok &aux tree)
247                 (multiple-value-setq (tree tok) (multiplicative tok))
248                 (loop while (member tok '(ADD SUB)) do
249                    (multiple-value-bind (right next) (multiplicative (next))
250                      (setq tree (list tok tree right)
251                            tok next)))
252                 (values tree tok))
253               (multiplicative (tok &aux tree)
254                 (multiple-value-setq (tree tok) (unary tok))
255                 (loop while (member tok '(MUL FLOOR MOD)) do
256                    (multiple-value-bind (right next) (unary (next))
257                      (setq tree (list tok tree right)
258                            tok next)))
259                 (values tree tok))
260               (unary (tok &aux tree)
261                 (cond ((eq tok 'LPAR)
262                        (multiple-value-setq (tree tok) (conditional (next)))
263                        (unless (eq tok 'RPAR)
264                          (error _"Expected close-paren."))
265                        (values tree (next)))
266                       ((numberp tok)
267                        (values tok (next)))
268                       ((eql tok 'n)
269                        (values tok (next)))
270                       ((eql tok 'ADD)
271                        (unary (next)))
272                       ((eql tok 'SUB)
273                        (multiple-value-setq (tree tok) (unary (next)))
274                        (values (list '- tree) tok))
275                       ((eql tok 'LOGNOT32)
276                        (multiple-value-setq (tree tok) (unary (next)))
277                        (values (list 'LOGNOT32 tree) tok))
278                       ((eql tok 'NOT)
279                        (multiple-value-setq (tree tok) (unary (next)))
280                        (values (list 'CNOT tree) tok))
281                       (t
282                        (error _"Unexpected token: ~S." tok)))))
283        (multiple-value-bind (tree end) (conditional (next))
284          (unless (eq end 'END)
285            (error _"Expecting end of expression.  ~S." end))
286          (let ((*compile-print* nil))
287            (compile nil
288                     `(lambda (n)
289                        (declare (type (unsigned-byte 32) n)
290                                 (optimize (space 3)))
291                        (flet ((add   (a b) (ldb (byte 32 0) (+ a b)))
292                               (sub   (a b) (ldb (byte 32 0) (- a b)))
293                               (mul   (a b) (ldb (byte 32 0) (* a b)))
294                               (shl   (a b) (ldb (byte 32 0) (ash a b)))
295                               (shr   (a b) (ash a (- b)))
296                               (cmp=  (a b) (if (= a b) 1 0))
297                               (cmp/= (a b) (if (/= a b) 1 0))
298                               (cmp<  (a b) (if (< a b) 1 0))
299                               (cmp<= (a b) (if (<= a b) 1 0))
300                               (cmp>  (a b) (if (> a b) 1 0))
301                               (cmp>= (a b) (if (>= a b) 1 0))
302                               (cand  (a b) (if (or (zerop a) (zerop b)) 0 1))
303                               (cor   (a b) (if (and (zerop a) (zerop b)) 0 1))
304                               (cnot  (a)   (if a 0 1))
305                               (lognot32 (a) (ldb (byte 32 0) (lognot a))))
306                          (declare (ignorable #'add #'sub #'mul #'shr #'shl
307                                              #'cmp= #'cmp/=
308                                              #'cmp< #'cmp<= #'cmp> #'cmp>=
309                                              #'cand #'cor #'cnot #'lognot32))
310                          ,tree)))))))
311    
312    (defun load-domain (domain locale &optional (locale-dir *locale-directories*))
313      (let ((file (locate-domain-file domain locale locale-dir))
314            (read #'read-lelong))
315        (unless file (return-from load-domain nil))
316        (with-open-file (stream file :direction :input :if-does-not-exist nil
317                                :element-type '(unsigned-byte 8))
318          (unless stream (return-from load-domain nil))
319          (let ((magic (read-lelong stream)))
320            (cond ((= magic #x950412de) (setq read #'read-lelong))
321                  ((= magic #xde120495) (setq read #'read-belong))
322                  (t
323                   (error _"Bad magic number in \"~A.mo\"." domain))))
324          (let ((version (funcall read stream))
325                (messages (funcall read stream))
326                (master (funcall read stream))
327                (translation (funcall read stream))
328                (entry (make-domain-entry)))
329            (declare (ignore version))
330            (setf (domain-entry-readfn entry) read)
331            (setf (domain-entry-domain entry) domain)
332            (setf (domain-entry-locale entry) locale)
333            (setf (domain-entry-file entry) file)
334            (dotimes (msg messages)
335              (file-position stream (+ master (* 8 msg)))
336              (let ((length (funcall read stream))
337                    (start (funcall read stream)))
338                (setf (gethash length (domain-entry-hash entry))
339                      (acons start (+ translation (* 8 msg))
340                             (gethash length (domain-entry-hash entry))))))
341            (setf (gethash domain *loaded-domains*) entry)
342            (find-encoding entry)))))
343    
344    (defun find-domain (domain locale &optional (locale-dir *locale-directories*))
345      (let ((found (gethash domain *loaded-domains*)))
346        (if (and found (string= (domain-entry-locale found) locale))
347            found
348            (load-domain domain locale locale-dir))))
349    
350    (declaim (inline string-to-octets))
351    (defun string-to-octets (string encoding)
352      (declare (ignorable encoding))
353      #+(and CMU Unicode)
354      (ext:string-to-octets string :external-format encoding)
355      #+Allegro
356      (excl:string-to-octets string :external-format encoding :null-terminate nil)
357      #+SBCL
358      (sb-ext:string-to-octets string :external-format encoding
359                               :null-terminate nil)
360      #+CLISP ;;@@ Not sure if encoding keyword is OK here
361      (ext:convert-string-to-bytes string encoding)
362      ;;@@ add other implementations
363      #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
364      (map-into (make-array (length string) :element-type '(unsigned-byte 8))
365                #'char-code string))
366    
367    (declaim (inline octets-to-string))
368    (defun octets-to-string (octets encoding)
369      (declare (ignorable encoding))
370      #+(and CMU Unicode)
371      (ext:octets-to-string octets :external-format encoding)
372      #+Allegro
373      (excl:octets-to-string octets :external-format encoding :end (length octets))
374      #+SBCL
375      (sb-ext:octets-to-string octets :external-format encoding)
376      #+CLISP ;;@@ Not sure if encoding keyword is OK here
377      (ext:convert-string-from-bytes octets encoding)
378      ;;@@ add other implementations
379      #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
380      (map-into (make-string (length octets)) #'code-char octets))
381    
382    (defun octets= (a b &key (start1 0) (end1 (length a))
383                             (start2 0) (end2 (length b)))
384      (declare (type (simple-array (unsigned-byte 8) (*)) a b)
385               (type (integer 0 #.array-dimension-limit) start1 end1 start2 end2)
386               (optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)))
387      (loop
388        (unless (= (aref a start1) (aref b start2)) (return nil))
389        (when (or (= (incf start1) end1) (= (incf start2) end2)) (return t))))
390    
391    (defun search-domain (octets domain pos)
392      (declare (type (simple-array (unsigned-byte 8) (*)) octets)
393               (type domain-entry domain)
394               (type list pos)
395               (optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)
396                         #+CMU (ext:inhibit-warnings 3))) ; quiet about boxing
397      (when pos
398        (let ((temp (make-array 120 :element-type '(unsigned-byte 8)))
399              (length (length octets)))
400          (with-open-file (stream (domain-entry-file domain)
401                                  :direction :input
402                                  :element-type '(unsigned-byte 8))
403            (dolist (entry pos)
404              (file-position stream (car entry))
405              (let ((off 0)
406                    (end (read-sequence temp stream
407                                        :end (min 120 length))))
408                (declare (type (integer 0 #.array-dimension-limit) off end))
409                (loop while (octets= octets temp
410                              :start1 off
411                              :end1 (min (+ off 120) length)
412                              :end2 end)
413                  do
414                    (incf off end)
415                    (when (< off length)
416                      (setf end (read-sequence temp stream
417                                               :end (min 120 (- length off))))))
418                (when (= off length)
419                  (file-position stream (cdr entry))
420                  (let* ((len (funcall (domain-entry-readfn domain) stream))
421                         (off (funcall (domain-entry-readfn domain) stream))
422                         (tmp (make-array len :element-type '(unsigned-byte 8))))
423                    (file-position stream off)
424                    (read-sequence tmp stream)
425                    (return (values tmp entry))))))))))
426    
427    (defun domain-lookup (string domain)
428      (declare (type string string) (type domain-entry domain)
429               (optimize (speed 3) (space 2) (safety 0)))
430      (or (if (null (domain-entry-encoding domain)) string)
431          (gethash string (domain-entry-hash domain))
432          (let* ((octets (string-to-octets string
433                                           (domain-entry-encoding domain)))
434                 (length (length octets))
435                 (pos (gethash length (domain-entry-hash domain))))
436            (declare (type (simple-array (unsigned-byte 8) (*)) octets))
437            (multiple-value-bind (tmp entry) (search-domain octets domain pos)
438              (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
439              (when tmp
440                (let ((temp (delete entry pos :test #'eq)))
441                  (if temp
442                      (setf (gethash length (domain-entry-hash domain)) temp)
443                      (remhash length (domain-entry-hash domain))))
444                (setf (gethash (copy-seq string) (domain-entry-hash domain))
445                    (octets-to-string tmp (domain-entry-encoding domain))))))))
446    
447    (defun domain-lookup-plural (singular plural domain)
448      (declare (type string singular plural) (type domain-entry domain)
449               (optimize (speed 3) (space 2) (safety 0)))
450      (or (if (null (domain-entry-encoding domain)) nil)
451          (gethash (cons singular plural) (domain-entry-hash domain))
452          (let* ((octets (let* ((a (string-to-octets singular
453                                                   (domain-entry-encoding domain)))
454                                (b (string-to-octets plural
455                                                   (domain-entry-encoding domain)))
456                                (c (make-array (+ (length a) (length b) 1)
457                                               :element-type '(unsigned-byte 8))))
458                           (declare (type (simple-array (unsigned-byte 8) (*))
459                                          a b c))
460                           (replace c a)
461                           (setf (aref c (length a)) 0)
462                           (replace c b :start1 (+ (length a) 1))
463                           c))
464                 (length (length octets))
465                 (pos (gethash length (domain-entry-hash domain))))
466            (declare (type (simple-array (unsigned-byte 8) (*)) octets)
467                     (type list pos))
468            (multiple-value-bind (tmp entry) (search-domain octets domain pos)
469              (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
470              (when tmp
471                (prog1
472                    (setf (gethash (cons (copy-seq singular) (copy-seq plural))
473                                   (domain-entry-hash domain))
474                        (loop for i = 0 then (1+ j)
475                               as j = (position 0 tmp :start i)
476                          collect (octets-to-string (subseq tmp i j)
477                                                    (domain-entry-encoding domain))
478                          while j))
479                  (let ((temp (delete entry pos :test #'eq)))
480                    (if temp
481                        (setf (gethash length (domain-entry-hash domain)) temp)
482                        (remhash length (domain-entry-hash domain))))
483                  (when (null (domain-entry-plurals domain))
484                    (setf (domain-entry-plurals domain)
485                        (parse-plurals domain)))))))))
486    
487    (declaim (inline getenv)
488             (ftype (function (string) (or null string)) getenv))
489    (defun getenv (var)
490      (let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD")
491                                            ext:*environment-list*))
492                 #+SBCL (sb-ext:posix-getenv var)
493                 #+Allegro (system:getenv var)
494                 #+LispWorks (hcl:getenv var)
495                 #+clisp (ext:getenv var)
496                 #+(or openmcl mcl) (ccl::getenv var)
497                 #+(or gcl ecl) (si::getenv var)))
498        (if (equal val "") nil val)))
499    
500    (defun setlocale (&optional locale)
501      (setf *locale* (or locale
502                         (getenv "LANGUAGE")
503                         (getenv "LC_ALL")
504                         (getenv "LC_MESSAGES")
505                         (getenv "LANG")
506                         *locale*)))
507    
508    (defmacro textdomain (domain)
509      `(eval-when (:compile-toplevel :execute)
510         (setf *default-domain* ,domain)))
511    
512    (defmacro gettext (string)
513      _N"Look up STRING in the current message domain and return its translation."
514      `(dgettext ,*default-domain* ,string))
515    
516    (defmacro ngettext (singular plural n)
517      _N"Look up the singular or plural form of a message in the current domain."
518      `(dngettext ,*default-domain* ,singular ,plural ,n))
519    
520    (declaim (inline dgettext))
521    (defun dgettext (domain string)
522      _N"Look up STRING in the specified message domain and return its translation."
523      (declare (optimize (speed 3) (space 2) (safety 0)))
524      (let ((domain (and domain (find-domain domain *locale*))))
525        (or (and domain (domain-lookup string domain)) string)))
526    
527    (defun dngettext (domain singular plural n)
528      _N"Look up the singular or plural form of a message in the specified domain."
529      (declare (type integer n)
530               (optimize (speed 3) (space 2) (safety 0)))
531      (let* ((domain (and domain (find-domain domain *locale*)))
532             (list (and domain (domain-lookup-plural singular plural domain))))
533        (if list
534            (nth (the integer
535                   (funcall (the function (domain-entry-plurals domain)) n))
536                 list)
537            (if (= n 1) singular plural))))
538    
539    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540    
541    #-runtime
542    (defvar *translator-comment* nil)
543    
544    #-runtime
545    (defvar *translations* (make-hash-table :test 'equal))
546    
547    #-runtime
548    (defun note-translatable (domain string &optional plural)
549      (when domain
550        (let* ((hash (or (gethash domain *translations*)
551                         (setf (gethash domain *translations*)
552                               (make-hash-table :test 'equal))))
553               (key (if plural (cons string plural) string))
554               (val (or (gethash key hash) (cons nil nil))))
555          (pushnew *translator-comment* (car val) :test #'equal)
556          (pushnew *compile-file-pathname* (cdr val) :test #'equal)
557          ;; FIXME: How does this happen?  Need to figure this out and get
558          ;; rid of this!
559          (unless key
560            (warn "Translate error with null key.  domain = ~S string = ~S~%"
561                   domain string))
562          (setf (gethash key hash) val)))
563      (setq *translator-comment* nil))
564    
565    (define-compiler-macro dgettext (&whole form domain string)
566      #-runtime
567      (when (and (stringp domain) (stringp string))
568        (note-translatable domain string))
569      form)
570    
571    (define-compiler-macro dngettext (&whole form domain singular plural n)
572      (declare (ignore n))
573      #-runtime
574      (when (and (stringp domain) (stringp singular) (stringp plural))
575        (note-translatable domain singular plural))
576      form)
577    
578    (defun read-translatable-string (stream char)
579      (declare (ignore char))
580        (case (peek-char nil stream nil nil t)
581          (#\" (let ((*read-suppress* nil)
582                     (string (read stream t nil t)))
583                 `(gettext ,string)))
584          (#\N (read-char stream t nil t)
585               (let ((*read-suppress* nil)
586                     (string (read stream t nil t)))
587                 #-runtime
588                 (note-translatable *default-domain* string)
589                 string))
590          (#\@ (error _"_@ is a reserved reader macro prefix."))
591          (otherwise
592           (let ((fn (get-macro-character #\_ nil)))
593             (if fn (funcall fn stream #\_) '_)))))
594    
595    ;; Process comments as usual, but look for lines that begin with
596    ;; "TRANSLATORS: ".  These lines are saved and written out as a
597    ;; translator comment for the next translatable string.
598    #-runtime
599    (defun read-comment (stream char)
600      (declare (optimize (speed 0) (space 3) #-gcl (debug 0))
601               (ignore char))
602      (do ((state 0)
603           (index 0)
604           (text nil)
605           (char (read-char stream nil nil t) (read-char stream nil nil t)))
606          ((or (not char) (char= char #\Newline))
607           (when text (setq *translator-comment* (copy-seq text))))
608        (cond ((and (= state 0) (char= char #\Space)) (setq state 1))
609              ((and (= state 0) (char= char #\T)) (setq state 1 index 1))
610              ((and (= state 0) (char/= char #\;)) (setq state 2))
611              ((and (= state 1) (= index 0) (char= char #\Space)) #|ignore|#)
612              ((= state 1)
613               (if (char= char (char "TRANSLATORS: " index))
614                   (when (= (incf index) 13)
615                     (setq state 3))
616                   (setq state 2)))
617              ((= state 3)
618               (when (null text)
619                 (setq text (make-array 50 :element-type 'character
620                                        :adjustable t :fill-pointer 0)))
621               (vector-push-extend char text))))
622      (values))
623    
624    #-runtime
625    (defun read-nested-comment (stream subchar arg)
626      (declare (ignore subchar arg)
627               (optimize (speed 0) (space 3) #-gcl (debug 0)))
628      (do ((level 1)
629           (state 0)
630           (index 0)
631           (text nil)
632           (prev (read-char stream t nil t) char)
633           (char (read-char stream t nil t) (read-char stream t nil t)))
634          (())
635        (cond ((and (char= prev #\|) (char= char #\#))
636               (when (zerop (decf level))
637                 (when text
638                   (setq *translator-comment*
639                         (string-right-trim '(#\Space #\Newline) text)))
640                 (return)))
641              ((and (char= prev #\#) (char= char #\|))
642               (setq state 2)
643               (incf level))
644              ((and (= state 0) (char= prev #\Space)) (setq state 1))
645              ((and (= state 0) (char= prev #\T))
646               (setq state 1 index 1))
647              ((= state 0) (setq state 2))
648              ((and (= state 1) (= index 0) (char= prev #\Space)) #| ignore |#)
649              ((= state 1)
650               (if (char= prev (char "TRANSLATORS: " index))
651                   (when (= (incf index) 13)
652                     (setq state 3))
653                   (setq state 2)))
654              ((= state 3)
655               (when (null text)
656                 (setq text (make-array 50 :element-type 'character
657                                        :adjustable t :fill-pointer 0)))
658               (vector-push-extend prev text))))
659      (values))
660    
661    (defun install ()
662      (set-macro-character #\_ #'read-translatable-string t)
663      #-runtime
664      (set-macro-character #\; #'read-comment)
665      #-runtime
666      (set-dispatch-macro-character #\# #\| #'read-nested-comment)
667      t)
668    
669    
670    ;; Dump the translatable strings.  The output is written to a file in
671    ;; the directory OUTPUT-DIRECTORY and its name is the domain.
672    #-runtime
673    (defun dump-pot-files (&key copyright output-directory)
674      (declare (optimize (speed 0) (space 3) #-gcl (debug 1)))
675      (labels ((b (key data)
676                 (format t "~@[~{~&#. ~A~}~%~]" (delete nil (car data)))
677                 (format t "~@[~&~<#: ~@;~@{~A~^ ~}~:@>~%~]"
678                         (delete nil (cdr data)))
679                 (cond ((consp key)
680                        (format t "~&msgid ") (str (car key) 6 0)
681                        (format t "~&msgid_plural ") (str (cdr key) 13 0)
682                        (format t "~&msgstr[0] \"\"~2%"))
683                       (t
684                        (unless key
685                          (format *debug-io* "*** WHOA!  key is NIL~%"))
686                        (format t "~&msgid ") (str key 6 0)
687                        (format t "~&msgstr \"\"~2%"))))
688               (str (string col start)
689                 (when (and (plusp col) (> (length string) (- 76 col)))
690                   (format t "\"\"~%"))
691                 (let ((nl (position #\Newline string :start start)))
692                   (cond ((and nl (< (- nl start) 76))
693                          (write-char #\")
694                          (wstr string start nl)
695                          (format t "\\n\"~%")
696                          (str string 0 (1+ nl)))
697                         ((< (- (length string) start) 76)
698                          (write-char #\")
699                          (wstr string start (length string))
700                          (write-char #\"))
701                         (t
702                          (let* ((a (+ start 1))
703                                 (b (+ start 76))
704                                 (b1 (position #\Space string :start a :end b
705                                               :from-end t))
706                                 (b2 (position-if (lambda (x)
707                                                    (position x ";:,?!)]}"))
708                                                  string :start a :end b
709                                                  :from-end t))
710                                 (b3 (position-if (lambda (x)
711                                                    (position x "\"'-"))
712                                                  string :start a :end b
713                                                  :from-end t))
714                                 (b4 (position-if #'digit-char-p
715                                                  string :start a :end b
716                                                  :from-end t))
717                                 (b5 (position-if #'alpha-char-p
718                                                  string :start a :end b
719                                                  :from-end t))
720                                 (g1 (if b1 (* (- b b1) (- b b1) .03) 10000))
721                                 (g2 (if b2 (* (- b b2) (- b b2) .20) 10000))
722                                 (g3 (if b3 (* (- b b3) (- b b3) .97) 10000))
723                                 (g4 (if b4 (* (- b b4) (- b b4) 1.3) 10000))
724                                 (g5 (if b5 (* (- b b5) (- b b5) 2.0) 10000))
725                                 (g (min g1 g2 g3 g4 g5))
726                                 (end (1+ (cond ((> g 750) b)
727                                                ((= g g1) b1)
728                                                ((= g g2) b2)
729                                                ((= g g3) b3)
730                                                ((= g g4) b4)
731                                                ((= g g5) b5)))))
732                            #+(or)
733                            (progn
734                              (format t "~&Splitting ~S:~%"
735                                      (subseq string start b))
736                              (format t "~{~&  b~D=~D; goodness=~F~}~%"
737                                      (list 1 b1 g1 2 b2 g2 3 b3 g3 4 b4 g4 5 b5 g5
738                                            6 b 10000))
739                              (format t "~&  best=~F == ~D~%" g end)
740                              (format t "~&  Part1=~S~%  Part2=~S~%"
741                                      (subseq string start end)
742                                      (subseq string end b)))
743                            (write-char #\")
744                            (wstr string start end)
745                            (write-char #\") (terpri)
746                            (str string 0 end))))))
747               (wstr (string start end)
748                 (format *debug-io* "wstr = ~S (~D to ~D)~%" string start end)
749                 (loop while (< start end) do
750                   (let ((i (position-if (lambda (x)
751                                           (or (char= x #\") (char= x #\\)))
752                                         string :start start :end end)))
753                     (write-string string nil :start start :end (or i end))
754                     (when i (write-char #\\ nil) (write-char (char string i) nil))
755                     (setq start (if i (1+ i) end)))))
756               (a (domain hash)
757                 (with-open-file (*standard-output*
758                                  (merge-pathnames (make-pathname :name domain
759                                                                  :type "pot")
760                                                   output-directory)
761                                  :direction :output
762                                  :if-exists :new-version
763                                  :external-format :utf8)
764                   (format t "~&#@ ~A~2%" domain)
765                   (format t "~&# SOME DESCRIPTIVE TITLE~%")
766                   (format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright)
767                   (format t "~&# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR~%")
768                   (format t "~&#~%#, fuzzy~%msgid \"\"~%msgstr \"\"~%")
769                   (format t "~&\"Project-Id-Version: PACKAGE VERSION\\n\"~%")
770                   (format t "~&\"Report-Msgid-Bugs-To: \\n\"~%")
771                   (format t "~&\"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"~%")
772                   (format t "~&\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"~%")
773                   (format t "~&\"Language-Team: LANGUAGE <LL@li.org>\\n\"~%")
774                   (format t "~&\"MIME-Version: 1.0\\n\"~%")
775                   (format t "~&\"Content-Type: text/plain; charset=UTF-8\\n\"~%")
776                   (format t "~&\"Content-Transfer-Encoding: 8bit\\n\"~2%")
777                   (maphash #'b hash))))
778        (maphash #'a *translations*)
779        #+(or)
780        (clrhash *translations*))
781      nil)
782    
783    
784    
785    (eval-when (:compile-toplevel :execute)
786      (setq *default-domain* nil)
787      (unless (and (fboundp 'intl:read-translatable-string)
788                   (eq (get-macro-character #\_)
789                       (fdefinition 'intl:read-translatable-string)))
790        (set-syntax-from-char #\_ #\_)))
791    
792    (install)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.2.3

  ViewVC Help
Powered by ViewVC 1.1.5