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

Contents of /src/code/intl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Wed Jul 14 03:13:20 2010 UTC (3 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, snapshot-2010-12, snapshot-2010-11, release-20b-pre1, release-20b-pre2, cross-sparc-branch-base, sparc-tramp-assem-2010-07-19, snapshot-2010-08, RELEASE_20b
Branch point for: cross-sparc-branch, sparc-tramp-assem-branch, RELEASE-20B-BRANCH
Changes since 1.7: +7 -6 lines
Oops.  Previous implementation of with-textdomain didn't actually
work.  Use this new one.

code/intl.lisp:
o New WITH-TEXTDOMAIN.

code/signal.lisp:
o Update uses of WITH-TEXTDOMAIN.

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

  ViewVC Help
Powered by ViewVC 1.1.5