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

Contents of /src/code/intl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sat Dec 11 22:39:46 2010 UTC (3 years, 4 months ago) by rtoy
Branch: MAIN
Changes since 1.8: +45 -25 lines
Speed up building on sparc.  Time taken is now almost half!  This was
caused by all the calls to stat in PROBE-FILE in LOCATE-DOMAIN-FILE
for files that did not exist.  The default locale was C, so every
message lookup was causing many stat's to non-exist files.  (There
were over 1000 calls/sec on a 750 MHz sparc!)

So we cache all the calls to PROBE-FILE in LOCATE-DOMAIN-FILE.  But
just in case, we also allow the user to get at the hash table to
examine it (GET-DOMAIN-FILE-CACHE) and also allow the user to clear it
(CLEAR-DOMAIN-FILE-CACHE) in case new translations are added without
restarting lisp.
1 rtoy 1.2 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
2    
3 rtoy 1.9 ;;; $Revision: 1.9 $
4 rtoy 1.2 ;;; 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 rtoy 1.9 (ext:file-comment "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/intl.lisp,v 1.9 2010/12/11 22:39:46 rtoy Exp $")
27 rtoy 1.2
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 rtoy 1.5 "The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT.
51 rtoy 1.2 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 #+(or)(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 #+(or)(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 rtoy 1.9 ;; If the domain file doesn't exist because the locale isn't
83     ;; supported, we end up doing a huge number of stats looking for a
84     ;; non-existent file everytime a translation is needed. This is
85     ;; really expensive. So create a cache to hold the results.
86     (let ((domain-file-cache (make-hash-table :test 'equal)))
87     (defun get-domain-file-cache ()
88     ;; Mostly for debugging to let the user get at the cache.
89     domain-file-cache)
90     (defun clear-domain-file-cache ()
91     ;; Mostly for debugging. But also useful if we now have installed
92     ;; some new translations.
93     (clrhash domain-file-cache))
94     (defun locate-domain-file (domain locale locale-dir)
95     ;; The default locale-dir includes search lists. If we get called
96     ;; before the search lists are initialized, we lose. The search
97     ;; lists are initialized in environment-init, which sets
98     ;; *environment-list-initialized*. This way, we return NIL to
99     ;; indicate there's no domain file to use.
100     (when lisp::*environment-list-initialized*
101     (flet ((path (locale base)
102     (merge-pathnames (make-pathname :directory (list :relative locale
103     "LC_MESSAGES")
104     :name domain :type "mo")
105     base))
106     (memoized-probe-file (p)
107     ;; Cache the results of probe-file and return the
108     ;; cached value when possible.
109     (multiple-value-bind (value foundp)
110     (gethash p domain-file-cache)
111     (if foundp
112     value
113     (setf (gethash p domain-file-cache) (probe-file p))))))
114     (let ((locale (or (gethash locale *locale-aliases*) locale)))
115     (dolist (base (if (listp locale-dir) locale-dir (list locale-dir)))
116     (let ((probe
117     (or (memoized-probe-file (path locale base))
118     (let ((dot (position #\. locale)))
119     (and dot (memoized-probe-file (path (subseq locale 0 dot) base))))
120     (let ((at (position #\@ locale)))
121     (and at (memoized-probe-file (path (subseq locale 0 at) base))))
122     (let ((us (position #\_ locale)))
123     (and us (memoized-probe-file (path (subseq locale 0 us) base)))))))
124     (when probe (return probe)))))))))
125 rtoy 1.2
126     (defun find-encoding (domain)
127     (when (null (domain-entry-encoding domain))
128     (setf (domain-entry-encoding domain) :iso-8859-1)
129     ;; Domain lookup can call the compiler, so set the locale to "C"
130     ;; so things work.
131     (let* ((*locale* "C")
132     (header (domain-lookup "" domain))
133     (ctype (search "Content-Type: " header))
134     (eoln (and ctype (position #\Newline header :start ctype)))
135     (charset (and ctype (search "; charset=" header
136     :start2 ctype :end2 eoln))))
137     (when charset
138     (incf charset 10)
139     (loop for i upfrom charset below eoln as c = (char header i)
140     while (or (alphanumericp c) (eql c #\-))
141     finally (setf (domain-entry-encoding domain)
142     (intern (nstring-upcase (subseq header charset i))
143     "KEYWORD"))))))
144     domain)
145    
146     (defun parse-plurals (domain)
147     (let* ((header (domain-lookup "" domain))
148     (plurals (search "Plural-Forms: " header))
149     (default (lambda (n) (if (= n 1) 0 1))))
150     (if (and plurals
151     (> (length header) (+ plurals 36))
152     (string= header "nplurals="
153     :start1 (+ plurals 14) :end1 (+ plurals 23)))
154     (let ((nplurals
155     (parse-integer header :start (+ plurals 23) :junk-allowed t))
156     (point (+ (position #\; header :start (+ plurals 23)) 2)))
157     (if (and (> (length header) (+ point 10))
158     (string= header "plural=" :start1 point :end1 (+ point 7)))
159     (values (parse-expr header (+ point 7)) nplurals)
160     (values default 2)))
161     (values default 2))))
162    
163     (defun parse-expr (string pos)
164     (labels ((next ()
165     (loop while (member (char string pos) '(#\Space #\Tab #\Newline))
166     do (incf pos))
167     (case (char string (1- (incf pos)))
168     (#\n 'n)
169     (#\? 'IF)
170     (#\: 'THEN)
171     (#\( 'LPAR)
172     (#\) 'RPAR)
173     (#\^ 'LOGXOR)
174     (#\+ 'ADD)
175     (#\- 'SUB)
176     (#\* 'MUL)
177     (#\/ 'FLOOR)
178     (#\% 'MOD)
179     (#\~ 'LOGNOT32)
180     (#\; 'END)
181     (#\| (if (char= (char string pos) #\|)
182     (progn (incf pos) 'COR)
183     'LOGIOR))
184     (#\& (if (char= (char string pos) #\&)
185     (progn (incf pos) 'CAND)
186     'LOGAND))
187     (#\= (if (char= (char string pos) #\=)
188     (progn (incf pos) 'CMP=)
189 rtoy 1.6 (error (intl:gettext "Encountered illegal token: ="))))
190 rtoy 1.2 (#\! (if (char= (char string pos) #\=)
191     (progn (incf pos) 'CMP/=)
192     'NOT))
193     (#\< (case (char string pos)
194     (#\= (incf pos) 'CMP<=)
195     (#\< (incf pos) 'SHL)
196     (otherwise 'CMP<)))
197     (#\> (case (char string pos)
198     (#\= (incf pos) 'CMP>=)
199     (#\> (incf pos) 'SHR)
200     (otherwise 'CMP>)))
201     (otherwise (let ((n (digit-char-p (char string (1- pos)))))
202     (if n
203     (loop for nx = (digit-char-p (char string pos))
204     while nx
205     do (setq n (+ (* n 10) nx)) (incf pos)
206     finally (return n))
207 rtoy 1.6 (error (intl:gettext "Encountered illegal token: ~C")
208 rtoy 1.2 (char string (1- pos))))))))
209     (conditional (tok &aux tree)
210     (multiple-value-setq (tree tok) (logical-or tok))
211     (when (eql tok 'IF)
212     (multiple-value-bind (right next) (logical-or (next))
213     (unless (eql next 'THEN)
214 rtoy 1.6 (error (intl:gettext "Expected : in ?: construct")))
215 rtoy 1.2 (multiple-value-bind (else next) (conditional (next))
216     (setq tree (list tok (list 'zerop tree) else right)
217     tok next))))
218     (values tree tok))
219     (logical-or (tok &aux tree)
220     (multiple-value-setq (tree tok) (logical-and tok))
221     (loop while (eql tok 'COR) do
222     (multiple-value-bind (right next) (logical-and (next))
223     (setq tree (list tok tree right)
224     tok next)))
225     (values tree tok))
226     (logical-and (tok &aux tree)
227     (multiple-value-setq (tree tok) (inclusive-or tok))
228     (loop while (eql tok 'CAND) do
229     (multiple-value-bind (right next) (inclusive-or (next))
230     (setq tree (list tok tree right)
231     tok next)))
232     (values tree tok))
233     (inclusive-or (tok &aux tree)
234     (multiple-value-setq (tree tok) (exclusive-or tok))
235     (loop while (eql tok 'LOGIOR) do
236     (multiple-value-bind (right next) (exclusive-or (next))
237     (setq tree (list tok tree right)
238     tok next)))
239     (values tree tok))
240     (exclusive-or (tok &aux tree)
241     (multiple-value-setq (tree tok) (bitwise-and tok))
242     (loop while (eql tok 'LOGXOR) do
243     (multiple-value-bind (right next) (bitwise-and (next))
244     (setq tree (list tok tree right)
245     tok next)))
246     (values tree tok))
247     (bitwise-and (tok &aux tree)
248     (multiple-value-setq (tree tok) (equality tok))
249     (loop while (eql tok 'LOGAND) do
250     (multiple-value-bind (right next) (equality (next))
251     (setq tree (list tok tree right)
252     tok next)))
253     (values tree tok))
254     (equality (tok &aux tree)
255     (multiple-value-setq (tree tok) (relational tok))
256     (loop while (member tok '(CMP= CMP/=)) do
257     (multiple-value-bind (right next) (relational (next))
258     (setq tree (list tok tree right)
259     tok next)))
260     (values tree tok))
261     (relational (tok &aux tree)
262     (multiple-value-setq (tree tok) (shift tok))
263     (loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do
264     (multiple-value-bind (right next) (shift (next))
265     (setq tree (list tok tree right)
266     tok next)))
267     (values tree tok))
268     (shift (tok &aux tree)
269     (multiple-value-setq (tree tok) (additive tok))
270     (loop while (member tok '(SHL SHR)) do
271     (multiple-value-bind (right next) (additive (next))
272     (setq tree (list tok tree right)
273     tok next)))
274     (values tree tok))
275     (additive (tok &aux tree)
276     (multiple-value-setq (tree tok) (multiplicative tok))
277     (loop while (member tok '(ADD SUB)) do
278     (multiple-value-bind (right next) (multiplicative (next))
279     (setq tree (list tok tree right)
280     tok next)))
281     (values tree tok))
282     (multiplicative (tok &aux tree)
283     (multiple-value-setq (tree tok) (unary tok))
284     (loop while (member tok '(MUL FLOOR MOD)) do
285     (multiple-value-bind (right next) (unary (next))
286     (setq tree (list tok tree right)
287     tok next)))
288     (values tree tok))
289     (unary (tok &aux tree)
290     (cond ((eq tok 'LPAR)
291     (multiple-value-setq (tree tok) (conditional (next)))
292     (unless (eq tok 'RPAR)
293 rtoy 1.6 (error (intl:gettext "Expected close-paren.")))
294 rtoy 1.2 (values tree (next)))
295     ((numberp tok)
296     (values tok (next)))
297     ((eql tok 'n)
298     (values tok (next)))
299     ((eql tok 'ADD)
300     (unary (next)))
301     ((eql tok 'SUB)
302     (multiple-value-setq (tree tok) (unary (next)))
303     (values (list '- tree) tok))
304     ((eql tok 'LOGNOT32)
305     (multiple-value-setq (tree tok) (unary (next)))
306     (values (list 'LOGNOT32 tree) tok))
307     ((eql tok 'NOT)
308     (multiple-value-setq (tree tok) (unary (next)))
309     (values (list 'CNOT tree) tok))
310     (t
311 rtoy 1.6 (error (intl:gettext "Unexpected token: ~S.") tok)))))
312 rtoy 1.2 (multiple-value-bind (tree end) (conditional (next))
313     (unless (eq end 'END)
314 rtoy 1.6 (error (intl:gettext "Expecting end of expression. ~S.") end))
315 rtoy 1.2 (let ((*compile-print* nil))
316     (compile nil
317     `(lambda (n)
318     (declare (type (unsigned-byte 32) n)
319     (optimize (space 3)))
320     (flet ((add (a b) (ldb (byte 32 0) (+ a b)))
321     (sub (a b) (ldb (byte 32 0) (- a b)))
322     (mul (a b) (ldb (byte 32 0) (* a b)))
323     (shl (a b) (ldb (byte 32 0) (ash a b)))
324     (shr (a b) (ash a (- b)))
325     (cmp= (a b) (if (= a b) 1 0))
326     (cmp/= (a b) (if (/= a b) 1 0))
327     (cmp< (a b) (if (< a b) 1 0))
328     (cmp<= (a b) (if (<= a b) 1 0))
329     (cmp> (a b) (if (> a b) 1 0))
330     (cmp>= (a b) (if (>= a b) 1 0))
331     (cand (a b) (if (or (zerop a) (zerop b)) 0 1))
332     (cor (a b) (if (and (zerop a) (zerop b)) 0 1))
333     (cnot (a) (if a 0 1))
334     (lognot32 (a) (ldb (byte 32 0) (lognot a))))
335     (declare (ignorable #'add #'sub #'mul #'shr #'shl
336     #'cmp= #'cmp/=
337     #'cmp< #'cmp<= #'cmp> #'cmp>=
338     #'cand #'cor #'cnot #'lognot32))
339     ,tree)))))))
340    
341     (defun load-domain (domain locale &optional (locale-dir *locale-directories*))
342     (let ((file (locate-domain-file domain locale locale-dir))
343     (read #'read-lelong))
344     (unless file (return-from load-domain nil))
345     (with-open-file (stream file :direction :input :if-does-not-exist nil
346     :element-type '(unsigned-byte 8))
347     (unless stream (return-from load-domain nil))
348     (let ((magic (read-lelong stream)))
349     (cond ((= magic #x950412de) (setq read #'read-lelong))
350     ((= magic #xde120495) (setq read #'read-belong))
351     (t
352     ;; DON'T translate this! If we can't load the domain,
353     ;; we can't print this message, Which causes an error
354     ;; that causes use to do a domain lookup again, which
355     ;; fails which cause an error message which ...
356     (warn "Bad magic number in \"~A.mo\"." domain)
357     (return-from load-domain nil))))
358     (let ((version (funcall read stream))
359     (messages (funcall read stream))
360     (master (funcall read stream))
361     (translation (funcall read stream))
362     (entry (make-domain-entry)))
363     (declare (ignore version))
364     (setf (domain-entry-readfn entry) read)
365     (setf (domain-entry-domain entry) domain)
366     (setf (domain-entry-locale entry) locale)
367     (setf (domain-entry-file entry) file)
368     (dotimes (msg messages)
369     (file-position stream (+ master (* 8 msg)))
370     (let ((length (funcall read stream))
371     (start (funcall read stream)))
372     (setf (gethash length (domain-entry-hash entry))
373     (acons start (+ translation (* 8 msg))
374     (gethash length (domain-entry-hash entry))))))
375     (setf (gethash domain *loaded-domains*) entry)
376     (find-encoding entry)))))
377    
378     (defun find-domain (domain locale &optional (locale-dir *locale-directories*))
379     (let ((found (gethash domain *loaded-domains*)))
380     (if (and found (string= (domain-entry-locale found) locale))
381     found
382     (load-domain domain locale locale-dir))))
383    
384     (declaim (inline string-to-octets))
385     (defun string-to-octets (string encoding)
386     (declare (ignorable encoding))
387     #+(and CMU Unicode)
388     (ext:string-to-octets string :external-format encoding)
389     #+Allegro
390     (excl:string-to-octets string :external-format encoding :null-terminate nil)
391     #+SBCL
392     (sb-ext:string-to-octets string :external-format encoding
393     :null-terminate nil)
394     #+CLISP ;;@@ Not sure if encoding keyword is OK here
395     (ext:convert-string-to-bytes string encoding)
396     ;;@@ add other implementations
397     #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
398     (map-into (make-array (length string) :element-type '(unsigned-byte 8))
399     #'char-code string))
400    
401     (declaim (inline octets-to-string))
402     (defun octets-to-string (octets encoding)
403     (declare (ignorable encoding))
404     #+(and CMU Unicode)
405     (ext:octets-to-string octets :external-format encoding)
406     #+Allegro
407     (excl:octets-to-string octets :external-format encoding :end (length octets))
408     #+SBCL
409     (sb-ext:octets-to-string octets :external-format encoding)
410     #+CLISP ;;@@ Not sure if encoding keyword is OK here
411     (ext:convert-string-from-bytes octets encoding)
412     ;;@@ add other implementations
413     #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
414     (map-into (make-string (length octets)) #'code-char octets))
415    
416     (defun octets= (a b &key (start1 0) (end1 (length a))
417     (start2 0) (end2 (length b)))
418     (declare (type (simple-array (unsigned-byte 8) (*)) a b)
419     (type (integer 0 #.array-dimension-limit) start1 end1 start2 end2)
420     #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)))
421     (when (and (< start1 end1)
422     (< start2 end2))
423     (loop
424     (unless (= (aref a start1) (aref b start2)) (return nil))
425     (when (or (= (incf start1) end1) (= (incf start2) end2)) (return t)))))
426    
427     (defun search-domain (octets domain pos)
428     (declare (type (simple-array (unsigned-byte 8) (*)) octets)
429     (type domain-entry domain)
430     (type list pos)
431     #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)
432     #+CMU (ext:inhibit-warnings 3))) ; quiet about boxing
433     (when pos
434     (let ((temp (make-array 120 :element-type '(unsigned-byte 8)))
435     (length (length octets)))
436     (with-open-file (stream (domain-entry-file domain)
437     :direction :input
438     :element-type '(unsigned-byte 8))
439     (dolist (entry pos)
440     (file-position stream (car entry))
441     (let ((off 0)
442     (end (read-sequence temp stream
443     :end (min 120 length))))
444     (declare (type (integer 0 #.array-dimension-limit) off end))
445     (loop while (octets= octets temp
446     :start1 off
447     :end1 (min (+ off 120) length)
448     :end2 end)
449     do
450     (incf off end)
451     (when (< off length)
452     (setf end (read-sequence temp stream
453     :end (min 120 (- length off))))))
454     (when (= off length)
455     (file-position stream (cdr entry))
456     (let* ((len (funcall (domain-entry-readfn domain) stream))
457     (off (funcall (domain-entry-readfn domain) stream))
458     (tmp (make-array len :element-type '(unsigned-byte 8))))
459     (file-position stream off)
460     (read-sequence tmp stream)
461     (return (values tmp entry))))))))))
462    
463     (defun domain-lookup (string domain)
464     (declare (type string string) (type domain-entry domain)
465     #+(or)(optimize (speed 3) (space 2) (safety 0)))
466     (or (if (null (domain-entry-encoding domain)) string)
467     (gethash string (domain-entry-hash domain))
468     (let* ((octets (string-to-octets string
469     (domain-entry-encoding domain)))
470     (length (length octets))
471     (pos (gethash length (domain-entry-hash domain))))
472     (declare (type (simple-array (unsigned-byte 8) (*)) octets))
473     (multiple-value-bind (tmp entry) (search-domain octets domain pos)
474     (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
475     (when tmp
476     (let ((temp (delete entry pos :test #'eq)))
477     (if temp
478     (setf (gethash length (domain-entry-hash domain)) temp)
479     (remhash length (domain-entry-hash domain))))
480     (setf (gethash (copy-seq string) (domain-entry-hash domain))
481     (octets-to-string tmp (domain-entry-encoding domain))))))))
482    
483     (defun domain-lookup-plural (singular plural domain)
484     (declare (type string singular plural) (type domain-entry domain)
485     #+(or)(optimize (speed 3) (space 2) (safety 0)))
486     (or (if (null (domain-entry-encoding domain)) nil)
487     (gethash (cons singular plural) (domain-entry-hash domain))
488     (let* ((octets (let* ((a (string-to-octets singular
489     (domain-entry-encoding domain)))
490     (b (string-to-octets plural
491     (domain-entry-encoding domain)))
492     (c (make-array (+ (length a) (length b) 1)
493     :element-type '(unsigned-byte 8))))
494     (declare (type (simple-array (unsigned-byte 8) (*))
495     a b c))
496     (replace c a)
497     (setf (aref c (length a)) 0)
498     (replace c b :start1 (+ (length a) 1))
499     c))
500     (length (length octets))
501     (pos (gethash length (domain-entry-hash domain))))
502     (declare (type (simple-array (unsigned-byte 8) (*)) octets)
503     (type list pos))
504     (multiple-value-bind (tmp entry) (search-domain octets domain pos)
505     (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
506     (when tmp
507     (prog1
508     (setf (gethash (cons (copy-seq singular) (copy-seq plural))
509     (domain-entry-hash domain))
510     (loop for i = 0 then (1+ j)
511     as j = (position 0 tmp :start i)
512     collect (octets-to-string (subseq tmp i j)
513     (domain-entry-encoding domain))
514     while j))
515     (let ((temp (delete entry pos :test #'eq)))
516     (if temp
517     (setf (gethash length (domain-entry-hash domain)) temp)
518     (remhash length (domain-entry-hash domain))))
519     (when (null (domain-entry-plurals domain))
520     (setf (domain-entry-plurals domain)
521     (parse-plurals domain)))))))))
522    
523     (declaim (inline getenv)
524     (ftype (function (string) (or null string)) getenv))
525     (defun getenv (var)
526     (let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD")
527     ext:*environment-list*))
528     #+SBCL (sb-ext:posix-getenv var)
529     #+Allegro (system:getenv var)
530     #+LispWorks (hcl:getenv var)
531     #+clisp (ext:getenv var)
532     #+(or openmcl mcl) (ccl::getenv var)
533     #+(or gcl ecl) (si::getenv var)))
534     (if (equal val "") nil val)))
535    
536     (defun setlocale (&optional locale)
537     (setf *locale* (or locale
538     (getenv "LANGUAGE")
539     (getenv "LC_ALL")
540     (getenv "LC_MESSAGES")
541     (getenv "LANG")
542     *locale*)))
543    
544     (defmacro textdomain (domain)
545     `(eval-when (:compile-toplevel :execute)
546     (setf *default-domain* ,domain)))
547    
548 rtoy 1.7 ;; Set the textdomain to New-Domain for the body and then restore the
549     ;; domain to the original.
550 rtoy 1.8 (defmacro with-textdomain ((old-domain new-domain) &body body)
551     `(progn
552     (intl:textdomain ,new-domain)
553     ,@body
554     (intl:textdomain ,old-domain)))
555 rtoy 1.7
556 rtoy 1.2 (defmacro gettext (string)
557 rtoy 1.5 "Look up STRING in the current message domain and return its translation."
558 rtoy 1.2 `(dgettext ,*default-domain* ,string))
559    
560     (defmacro ngettext (singular plural n)
561 rtoy 1.5 "Look up the singular or plural form of a message in the current domain."
562 rtoy 1.2 `(dngettext ,*default-domain* ,singular ,plural ,n))
563    
564     (declaim (inline dgettext))
565     (defun dgettext (domain string)
566 rtoy 1.5 "Look up STRING in the specified message domain and return its translation."
567 rtoy 1.2 #+(or)(declare (optimize (speed 3) (space 2) (safety 0)))
568     (let ((domain (and domain (find-domain domain *locale*))))
569     (or (and domain (domain-lookup string domain)) string)))
570    
571     (defun dngettext (domain singular plural n)
572 rtoy 1.5 "Look up the singular or plural form of a message in the specified domain."
573 rtoy 1.2 (declare (type integer n)
574     #+(or)(optimize (speed 3) (space 2) (safety 0)))
575     (let* ((domain (and domain (find-domain domain *locale*)))
576     (list (and domain (domain-lookup-plural singular plural domain))))
577     (if list
578     (nth (the integer
579     (funcall (the function (domain-entry-plurals domain)) n))
580     list)
581     (if (= n 1) singular plural))))
582    
583     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
584    
585     #-runtime
586     (defvar *translator-comment* nil)
587    
588     #-runtime
589 rtoy 1.4 (defvar *translations* nil)
590    
591     #-runtime
592     (defun translation-enable ()
593     (setq *translations* (or *translations* (make-hash-table :test 'equal)))
594     t)
595    
596     #-runtime
597     (defun translation-disable ()
598     (setq *translations* nil))
599 rtoy 1.2
600     #-runtime
601     (defun note-translatable (domain string &optional plural)
602 rtoy 1.4 (when (and domain *translations*)
603 rtoy 1.2 (let* ((hash (or (gethash domain *translations*)
604     (setf (gethash domain *translations*)
605     (make-hash-table :test 'equal))))
606     (key (if plural (cons string plural) string))
607     (val (or (gethash key hash) (cons nil nil))))
608     (pushnew *translator-comment* (car val) :test #'equal)
609 rtoy 1.4 (pushnew (and *compile-file-truename* (enough-namestring *compile-file-truename*))
610     (cdr val) :test #'equal)
611 rtoy 1.2 ;; FIXME: How does this happen? Need to figure this out and get
612     ;; rid of this!
613     (unless key
614     (warn "Translate error with null key. domain = ~S string = ~S~%"
615     domain string))
616     (setf (gethash key hash) val)))
617     (setq *translator-comment* nil))
618    
619     (define-compiler-macro dgettext (&whole form domain string)
620     #-runtime
621     (when (and (stringp domain) (stringp string))
622     (note-translatable domain string))
623     form)
624    
625     (define-compiler-macro dngettext (&whole form domain singular plural n)
626     (declare (ignore n))
627     #-runtime
628     (when (and (stringp domain) (stringp singular) (stringp plural))
629     (note-translatable domain singular plural))
630     form)
631    
632     (defun read-translatable-string (stream char)
633     (declare (ignore char))
634     (case (peek-char nil stream nil nil t)
635     (#\" (let* ((*read-suppress* nil)
636     (string (read stream t nil t)))
637     (note-translatable *default-domain* string)
638     `(gettext ,string)))
639     (#\N (read-char stream t nil t)
640     (let* ((*read-suppress* nil)
641     (string (read stream t nil t)))
642     #-runtime
643     (note-translatable *default-domain* string)
644     string))
645     (#\@ (error _"_@ is a reserved reader macro prefix."))
646     (otherwise
647     (let ((fn (get-macro-character #\_ nil)))
648     (if fn (funcall fn stream #\_) '_)))))
649    
650     ;; Process comments as usual, but look for lines that begin with
651     ;; "TRANSLATORS: ". These lines are saved and written out as a
652     ;; translator comment for the next translatable string.
653     #-runtime
654     (defun read-comment (stream char)
655     (declare (optimize (speed 0) (space 3) #-gcl (debug 0))
656     (ignore char))
657     (do ((state 0)
658     (index 0)
659     (text nil)
660     (char (read-char stream nil nil t) (read-char stream nil nil t)))
661     ((or (not char) (char= char #\Newline))
662     (when text (setq *translator-comment* (copy-seq text))))
663     (cond ((and (= state 0) (char= char #\Space)) (setq state 1))
664     ((and (= state 0) (char= char #\T)) (setq state 1 index 1))
665     ((and (= state 0) (char/= char #\;)) (setq state 2))
666     ((and (= state 1) (= index 0) (char= char #\Space)) #|ignore|#)
667     ((= state 1)
668     (if (char= char (char "TRANSLATORS: " index))
669     (when (= (incf index) 13)
670     (setq state 3))
671     (setq state 2)))
672     ((= state 3)
673     (when (null text)
674     (setq text (make-array 50 :element-type 'character
675     :adjustable t :fill-pointer 0)))
676     (vector-push-extend char text))))
677     (values))
678    
679     #-runtime
680     (defun read-nested-comment (stream subchar arg)
681     (declare (ignore subchar arg)
682     (optimize (speed 0) (space 3) #-gcl (debug 0)))
683     (do ((level 1)
684     (state 0)
685     (index 0)
686     (text nil)
687     (prev (read-char stream t nil t) char)
688     (char (read-char stream t nil t) (read-char stream t nil t)))
689     (())
690     (cond ((and (char= prev #\|) (char= char #\#))
691     (when (zerop (decf level))
692     (when text
693     (setq *translator-comment*
694     (string-right-trim '(#\Space #\Newline) text)))
695     (return)))
696     ((and (char= prev #\#) (char= char #\|))
697     (setq state 2)
698     (incf level))
699     ((and (= state 0) (char= prev #\Space)) (setq state 1))
700     ((and (= state 0) (char= prev #\T))
701     (setq state 1 index 1))
702     ((= state 0) (setq state 2))
703     ((and (= state 1) (= index 0) (char= prev #\Space)) #| ignore |#)
704     ((= state 1)
705     (if (char= prev (char "TRANSLATORS: " index))
706     (when (= (incf index) 13)
707     (setq state 3))
708     (setq state 2)))
709     ((= state 3)
710     (when (null text)
711     (setq text (make-array 50 :element-type 'character
712     :adjustable t :fill-pointer 0)))
713     (vector-push-extend prev text))))
714     (values))
715    
716 rtoy 1.3 (defun install (&optional (rt *readtable*))
717     (set-macro-character #\_ #'read-translatable-string t rt)
718 rtoy 1.2 #-runtime
719 rtoy 1.3 (set-macro-character #\; #'read-comment nil rt)
720 rtoy 1.2 #-runtime
721 rtoy 1.3 (set-dispatch-macro-character #\# #\| #'read-nested-comment rt)
722 rtoy 1.2 t)
723    
724    
725     ;; Dump the translatable strings. The output is written to a file in
726     ;; the directory OUTPUT-DIRECTORY and its name is the domain.
727     #-runtime
728     (defun dump-pot-files (&key copyright output-directory)
729     ;;(declare (optimize (speed 0) (space 3) #-gcl (debug 1)))
730     (labels ((b (key data)
731     (format t "~@[~{~&#. ~A~}~%~]" (delete nil (car data)))
732     (format t "~@[~&~<#: ~@;~@{~A~^ ~}~:@>~%~]"
733     (delete nil (cdr data)))
734     (cond ((consp key)
735     (format t "~&msgid ") (str (car key) 6 0)
736     (format t "~&msgid_plural ") (str (cdr key) 13 0)
737     (format t "~&msgstr[0] \"\"~2%"))
738     (t
739     (cond
740     (key
741     (format t "~&msgid ") (str key 6 0)
742     (format t "~&msgstr \"\"~2%"))
743     (t
744     (format *error-output* "Skipping NIL key~%"))))))
745     (str (string col start)
746     (when (and (plusp col) (> (length string) (- 76 col)))
747     (format t "\"\"~%"))
748     (let ((nl (position #\Newline string :start start)))
749     (cond ((and nl (< (- nl start) 76))
750     (write-char #\")
751     (wstr string start nl)
752     (format t "\\n\"~%")
753     (str string 0 (1+ nl)))
754     ((< (- (length string) start) 76)
755     (write-char #\")
756     (wstr string start (length string))
757     (write-char #\"))
758     (t
759     (let* ((a (+ start 1))
760     (b (+ start 76))
761     (b1 (position #\Space string :start a :end b
762     :from-end t))
763     (b2 (position-if (lambda (x)
764     (position x ";:,?!)]}"))
765     string :start a :end b
766     :from-end t))
767     (b3 (position-if (lambda (x)
768     (position x "\"'-"))
769     string :start a :end b
770     :from-end t))
771     (b4 (position-if #'digit-char-p
772     string :start a :end b
773     :from-end t))
774     (b5 (position-if #'alpha-char-p
775     string :start a :end b
776     :from-end t))
777     (g1 (if b1 (* (- b b1) (- b b1) .03) 10000))
778     (g2 (if b2 (* (- b b2) (- b b2) .20) 10000))
779     (g3 (if b3 (* (- b b3) (- b b3) .97) 10000))
780     (g4 (if b4 (* (- b b4) (- b b4) 1.3) 10000))
781     (g5 (if b5 (* (- b b5) (- b b5) 2.0) 10000))
782     (g (min g1 g2 g3 g4 g5))
783     (end (1+ (cond ((> g 750) b)
784     ((= g g1) b1)
785     ((= g g2) b2)
786     ((= g g3) b3)
787     ((= g g4) b4)
788     ((= g g5) b5)))))
789     #+(or)
790     (progn
791     (format t "~&Splitting ~S:~%"
792     (subseq string start b))
793     (format t "~{~& b~D=~D; goodness=~F~}~%"
794     (list 1 b1 g1 2 b2 g2 3 b3 g3 4 b4 g4 5 b5 g5
795     6 b 10000))
796     (format t "~& best=~F == ~D~%" g end)
797     (format t "~& Part1=~S~% Part2=~S~%"
798     (subseq string start end)
799     (subseq string end b)))
800     (write-char #\")
801     (wstr string start end)
802     (write-char #\") (terpri)
803     (str string 0 end))))))
804     (wstr (string start end)
805     (loop while (< start end) do
806     (let ((i (position-if (lambda (x)
807     (or (char= x #\") (char= x #\\)))
808     string :start start :end end)))
809     (write-string string nil :start start :end (or i end))
810     (when i (write-char #\\ nil) (write-char (char string i) nil))
811     (setq start (if i (1+ i) end)))))
812     (a (domain hash)
813     (format t _"~&Dumping ~D messages for domain ~S~%"
814     (hash-table-count hash) domain)
815     (with-open-file (*standard-output*
816     (merge-pathnames (make-pathname :name domain
817     :type "pot")
818     output-directory)
819     :direction :output
820     :if-exists :new-version
821     ;;:external-format :utf8
822     :external-format :iso8859-1
823     )
824     (format t "~&#@ ~A~2%" domain)
825     (format t "~&# SOME DESCRIPTIVE TITLE~%")
826     (format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright)
827     (format t "~&# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR~%")
828     (format t "~&#~%#, fuzzy~%msgid \"\"~%msgstr \"\"~%")
829     (format t "~&\"Project-Id-Version: PACKAGE VERSION\\n\"~%")
830     (format t "~&\"Report-Msgid-Bugs-To: \\n\"~%")
831     (format t "~&\"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"~%")
832     (format t "~&\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"~%")
833     (format t "~&\"Language-Team: LANGUAGE <LL@li.org>\\n\"~%")
834     (format t "~&\"MIME-Version: 1.0\\n\"~%")
835     (format t "~&\"Content-Type: text/plain; charset=UTF-8\\n\"~%")
836     (format t "~&\"Content-Transfer-Encoding: 8bit\\n\"~2%")
837     (maphash #'b hash))))
838     (maphash #'a *translations*)
839     #+(or)
840     (clrhash *translations*))
841     nil)
842    
843    
844    
845     (eval-when (:compile-toplevel :execute)
846     (setq *default-domain* nil)
847     (unless (and (fboundp 'intl:read-translatable-string)
848     (eq (get-macro-character #\_)
849     (fdefinition 'intl:read-translatable-string)))
850     (set-syntax-from-char #\_ #\_)))
851    
852 rtoy 1.3 ;; Don't install the reader macros by default.
853     #+(or)
854     (install)

  ViewVC Help
Powered by ViewVC 1.1.5