Newer
Older
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
;;; $Revision: 1.11 $
;;; Copyright 1999-2010 Paul Foley (mycroft@actrix.gen.nz)
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this Software to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; provided that the above copyright notice and this permission notice
;;; are included in all copies or substantial portions of the Software.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.
(ext:file-comment "$Header: src/code/intl.lisp $")
(in-package "INTL")
(eval-when (:compile-toplevel :execute)
(defparameter intl::*default-domain* "cmucl")
(unless (and (fboundp 'intl:read-translatable-string)
(eq (get-macro-character #\_)
(fdefinition 'intl:read-translatable-string)))
(set-macro-character #\_ (lambda (stream char)
(declare (ignore char))
(case (peek-char nil stream nil nil t)
(#\" (values))
(#\N (read-char stream t nil t) (values))
(otherwise '_)))
t)))
(in-package "INTL")
(defvar *locale-directories*
'(#p"library:locale/" #p"/usr/share/locale/" #p"target:i18n/locale/"))
(defvar *locale* "C")
(defvar *default-domain* nil
"The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT.
Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.")
(defvar *loaded-domains* (make-hash-table :test 'equal))
(defvar *locale-aliases* (make-hash-table :test 'equal))
(defstruct domain-entry
(domain "" :type simple-base-string)
(locale "" :type simple-base-string)
(file #p"" :type pathname)
(plurals nil :type (or null function))
(hash (make-hash-table :test 'equal) :type hash-table)
(encoding nil)
(readfn #'identity :type function))
(declaim (ftype (function (stream) (unsigned-byte 32)) read-lelong))
(defun read-lelong (stream)
(declare #+(or)(optimize (speed 3) (space 2) (safety 0)
#+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn
(+ (the (unsigned-byte 8) (read-byte stream))
(ash (the (unsigned-byte 8) (read-byte stream)) 8)
(ash (the (unsigned-byte 8) (read-byte stream)) 16)
(ash (the (unsigned-byte 8) (read-byte stream)) 24)))
(declaim (ftype (function (stream) (unsigned-byte 32)) read-belong))
(defun read-belong (stream)
(declare #+(or)(optimize (speed 3) (space 2) (safety 0)
#+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn
(+ (ash (the (unsigned-byte 8) (read-byte stream)) 24)
(ash (the (unsigned-byte 8) (read-byte stream)) 16)
(ash (the (unsigned-byte 8) (read-byte stream)) 8)
(the (unsigned-byte 8) (read-byte stream))))
(defun locate-domain-file (domain locale locale-dir)
;; The default locale-dir includes search lists. If we get called
;; before the search lists are initialized, we lose. The search
;; lists are initialized in environment-init, which sets
;; *environment-list-initialized*. This way, we return NIL to
;; indicate there's no domain file to use.
(when lisp::*environment-list-initialized*
(flet ((path (locale base)
(merge-pathnames (make-pathname :directory (list :relative locale
"LC_MESSAGES")
:name domain :type "mo")
base)))
(let ((locale (or (gethash locale *locale-aliases*) locale)))
(dolist (base (if (listp locale-dir) locale-dir (list locale-dir)))
(let ((probe
(or (probe-file (path locale base))
(let ((dot (position #\. locale)))
(and dot (probe-file (path (subseq locale 0 dot) base))))
(let ((at (position #\@ locale)))
(and at (probe-file (path (subseq locale 0 at) base))))
(let ((us (position #\_ locale)))
(and us (probe-file (path (subseq locale 0 us) base)))))))
(when probe (return probe))))))))
(defun find-encoding (domain)
(when (null (domain-entry-encoding domain))
(setf (domain-entry-encoding domain) :iso8859-1)
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
;; Domain lookup can call the compiler, so set the locale to "C"
;; so things work.
(let* ((*locale* "C")
(header (domain-lookup "" domain))
(ctype (search "Content-Type: " header))
(eoln (and ctype (position #\Newline header :start ctype)))
(charset (and ctype (search "; charset=" header
:start2 ctype :end2 eoln))))
(when charset
(incf charset 10)
(loop for i upfrom charset below eoln as c = (char header i)
while (or (alphanumericp c) (eql c #\-))
finally (setf (domain-entry-encoding domain)
(intern (nstring-upcase (subseq header charset i))
"KEYWORD"))))))
domain)
(defun parse-plurals (domain)
(let* ((header (domain-lookup "" domain))
(plurals (search "Plural-Forms: " header))
(default (lambda (n) (if (= n 1) 0 1))))
(if (and plurals
(> (length header) (+ plurals 36))
(string= header "nplurals="
:start1 (+ plurals 14) :end1 (+ plurals 23)))
(let ((nplurals
(parse-integer header :start (+ plurals 23) :junk-allowed t))
(point (+ (position #\; header :start (+ plurals 23)) 2)))
(if (and (> (length header) (+ point 10))
(string= header "plural=" :start1 point :end1 (+ point 7)))
(values (parse-expr header (+ point 7)) nplurals)
(values default 2)))
(values default 2))))
(defun parse-expr (string pos)
(labels ((next ()
(loop while (member (char string pos) '(#\Space #\Tab #\Newline))
do (incf pos))
(case (char string (1- (incf pos)))
(#\n 'n)
(#\? 'IF)
(#\: 'THEN)
(#\( 'LPAR)
(#\) 'RPAR)
(#\^ 'LOGXOR)
(#\+ 'ADD)
(#\- 'SUB)
(#\* 'MUL)
(#\/ 'FLOOR)
(#\% 'MOD)
(#\~ 'LOGNOT32)
(#\; 'END)
(#\| (if (char= (char string pos) #\|)
(progn (incf pos) 'COR)
'LOGIOR))
(#\& (if (char= (char string pos) #\&)
(progn (incf pos) 'CAND)
'LOGAND))
(#\= (if (char= (char string pos) #\=)
(progn (incf pos) 'CMP=)
(error (intl:gettext "Encountered illegal token: ="))))
(#\! (if (char= (char string pos) #\=)
(progn (incf pos) 'CMP/=)
'NOT))
(#\< (case (char string pos)
(#\= (incf pos) 'CMP<=)
(#\< (incf pos) 'SHL)
(otherwise 'CMP<)))
(#\> (case (char string pos)
(#\= (incf pos) 'CMP>=)
(#\> (incf pos) 'SHR)
(otherwise 'CMP>)))
(otherwise (let ((n (digit-char-p (char string (1- pos)))))
(if n
(loop for nx = (digit-char-p (char string pos))
while nx
do (setq n (+ (* n 10) nx)) (incf pos)
finally (return n))
(error (intl:gettext "Encountered illegal token: ~C")
(char string (1- pos))))))))
(conditional (tok &aux tree)
(multiple-value-setq (tree tok) (logical-or tok))
(when (eql tok 'IF)
(multiple-value-bind (right next) (logical-or (next))
(unless (eql next 'THEN)
(error (intl:gettext "Expected : in ?: construct")))
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
(multiple-value-bind (else next) (conditional (next))
(setq tree (list tok (list 'zerop tree) else right)
tok next))))
(values tree tok))
(logical-or (tok &aux tree)
(multiple-value-setq (tree tok) (logical-and tok))
(loop while (eql tok 'COR) do
(multiple-value-bind (right next) (logical-and (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(logical-and (tok &aux tree)
(multiple-value-setq (tree tok) (inclusive-or tok))
(loop while (eql tok 'CAND) do
(multiple-value-bind (right next) (inclusive-or (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(inclusive-or (tok &aux tree)
(multiple-value-setq (tree tok) (exclusive-or tok))
(loop while (eql tok 'LOGIOR) do
(multiple-value-bind (right next) (exclusive-or (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(exclusive-or (tok &aux tree)
(multiple-value-setq (tree tok) (bitwise-and tok))
(loop while (eql tok 'LOGXOR) do
(multiple-value-bind (right next) (bitwise-and (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(bitwise-and (tok &aux tree)
(multiple-value-setq (tree tok) (equality tok))
(loop while (eql tok 'LOGAND) do
(multiple-value-bind (right next) (equality (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(equality (tok &aux tree)
(multiple-value-setq (tree tok) (relational tok))
(loop while (member tok '(CMP= CMP/=)) do
(multiple-value-bind (right next) (relational (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(relational (tok &aux tree)
(multiple-value-setq (tree tok) (shift tok))
(loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do
(multiple-value-bind (right next) (shift (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(shift (tok &aux tree)
(multiple-value-setq (tree tok) (additive tok))
(loop while (member tok '(SHL SHR)) do
(multiple-value-bind (right next) (additive (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(additive (tok &aux tree)
(multiple-value-setq (tree tok) (multiplicative tok))
(loop while (member tok '(ADD SUB)) do
(multiple-value-bind (right next) (multiplicative (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(multiplicative (tok &aux tree)
(multiple-value-setq (tree tok) (unary tok))
(loop while (member tok '(MUL FLOOR MOD)) do
(multiple-value-bind (right next) (unary (next))
(setq tree (list tok tree right)
tok next)))
(values tree tok))
(unary (tok &aux tree)
(cond ((eq tok 'LPAR)
(multiple-value-setq (tree tok) (conditional (next)))
(unless (eq tok 'RPAR)
(error (intl:gettext "Expected close-paren.")))
(values tree (next)))
((numberp tok)
(values tok (next)))
((eql tok 'n)
(values tok (next)))
((eql tok 'ADD)
(unary (next)))
((eql tok 'SUB)
(multiple-value-setq (tree tok) (unary (next)))
(values (list '- tree) tok))
((eql tok 'LOGNOT32)
(multiple-value-setq (tree tok) (unary (next)))
(values (list 'LOGNOT32 tree) tok))
((eql tok 'NOT)
(multiple-value-setq (tree tok) (unary (next)))
(values (list 'CNOT tree) tok))
(t
(error (intl:gettext "Unexpected token: ~S.") tok)))))
(multiple-value-bind (tree end) (conditional (next))
(unless (eq end 'END)
(error (intl:gettext "Expecting end of expression. ~S.") end))
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
(let ((*compile-print* nil))
(compile nil
`(lambda (n)
(declare (type (unsigned-byte 32) n)
(optimize (space 3)))
(flet ((add (a b) (ldb (byte 32 0) (+ a b)))
(sub (a b) (ldb (byte 32 0) (- a b)))
(mul (a b) (ldb (byte 32 0) (* a b)))
(shl (a b) (ldb (byte 32 0) (ash a b)))
(shr (a b) (ash a (- b)))
(cmp= (a b) (if (= a b) 1 0))
(cmp/= (a b) (if (/= a b) 1 0))
(cmp< (a b) (if (< a b) 1 0))
(cmp<= (a b) (if (<= a b) 1 0))
(cmp> (a b) (if (> a b) 1 0))
(cmp>= (a b) (if (>= a b) 1 0))
(cand (a b) (if (or (zerop a) (zerop b)) 0 1))
(cor (a b) (if (and (zerop a) (zerop b)) 0 1))
(cnot (a) (if a 0 1))
(lognot32 (a) (ldb (byte 32 0) (lognot a))))
(declare (ignorable #'add #'sub #'mul #'shr #'shl
#'cmp= #'cmp/=
#'cmp< #'cmp<= #'cmp> #'cmp>=
#'cand #'cor #'cnot #'lognot32))
,tree)))))))
(defun load-domain (domain locale &optional (locale-dir *locale-directories*))
(let ((file (locate-domain-file domain locale locale-dir))
(read #'read-lelong))
(unless file
(let ((entry (make-domain-entry :domain domain :locale locale
:hash (make-hash-table :size 0
:test 'equal))))
(setf (gethash domain *loaded-domains*) entry)
(return-from load-domain entry)))
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
(with-open-file (stream file :direction :input :if-does-not-exist nil
:element-type '(unsigned-byte 8))
(unless stream (return-from load-domain nil))
(let ((magic (read-lelong stream)))
(cond ((= magic #x950412de) (setq read #'read-lelong))
((= magic #xde120495) (setq read #'read-belong))
(t
;; DON'T translate this! If we can't load the domain,
;; we can't print this message, Which causes an error
;; that causes use to do a domain lookup again, which
;; fails which cause an error message which ...
(warn "Bad magic number in \"~A.mo\"." domain)
(return-from load-domain nil))))
(let ((version (funcall read stream))
(messages (funcall read stream))
(master (funcall read stream))
(translation (funcall read stream))
(entry (make-domain-entry)))
(declare (ignore version))
(setf (domain-entry-readfn entry) read)
(setf (domain-entry-domain entry) domain)
(setf (domain-entry-locale entry) locale)
(setf (domain-entry-file entry) file)
(dotimes (msg messages)
(file-position stream (+ master (* 8 msg)))
(let ((length (funcall read stream))
(start (funcall read stream)))
(setf (gethash length (domain-entry-hash entry))
(acons start (+ translation (* 8 msg))
(gethash length (domain-entry-hash entry))))))
(setf (gethash domain *loaded-domains*) entry)
(find-encoding entry)))))
(defun find-domain (domain locale &optional (locale-dir *locale-directories*))
(let ((found (gethash domain *loaded-domains*)))
(if (and found (string= (domain-entry-locale found) locale))
found
(load-domain domain locale locale-dir))))
(declaim (inline string-to-octets))
(defun string-to-octets (string encoding)
(declare (ignorable encoding))
#+(and CMU Unicode)
(ext:string-to-octets string :external-format encoding)
#+Allegro
(excl:string-to-octets string :external-format encoding :null-terminate nil)
#+SBCL
(sb-ext:string-to-octets string :external-format encoding
:null-terminate nil)
#+CLISP ;;@@ Not sure if encoding keyword is OK here
(ext:convert-string-to-bytes string encoding)
;;@@ add other implementations
#-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
(map-into (make-array (length string) :element-type '(unsigned-byte 8))
#'char-code string))
(declaim (inline octets-to-string))
(defun octets-to-string (octets encoding)
(declare (ignorable encoding))
#+(and CMU Unicode)
(ext:octets-to-string octets :external-format encoding)
#+Allegro
(excl:octets-to-string octets :external-format encoding :end (length octets))
#+SBCL
(sb-ext:octets-to-string octets :external-format encoding)
#+CLISP ;;@@ Not sure if encoding keyword is OK here
(ext:convert-string-from-bytes octets encoding)
;;@@ add other implementations
#-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#)
(map-into (make-string (length octets)) #'code-char octets))
(defun octets= (a b &key (start1 0) (end1 (length a))
(start2 0) (end2 (length b)))
(declare (type (simple-array (unsigned-byte 8) (*)) a b)
(type (integer 0 #.array-dimension-limit) start1 end1 start2 end2)
#+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)))
(when (and (< start1 end1)
(< start2 end2))
(loop
(unless (= (aref a start1) (aref b start2)) (return nil))
(when (or (= (incf start1) end1) (= (incf start2) end2)) (return t)))))
(defun search-domain (octets domain pos)
(declare (type (simple-array (unsigned-byte 8) (*)) octets)
(type domain-entry domain)
(type list pos)
#+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)
#+CMU (ext:inhibit-warnings 3))) ; quiet about boxing
(when pos
(let ((temp (make-array 120 :element-type '(unsigned-byte 8)))
(length (length octets)))
(with-open-file (stream (domain-entry-file domain)
:direction :input
:element-type '(unsigned-byte 8))
(dolist (entry pos)
(file-position stream (car entry))
(let ((off 0)
(end (read-sequence temp stream
:end (min 120 length))))
(declare (type (integer 0 #.array-dimension-limit) off end))
(loop while (octets= octets temp
:start1 off
:end1 (min (+ off 120) length)
:end2 end)
do
(incf off end)
(when (< off length)
(setf end (read-sequence temp stream
:end (min 120 (- length off))))))
(when (= off length)
(file-position stream (cdr entry))
(let* ((len (funcall (domain-entry-readfn domain) stream))
(off (funcall (domain-entry-readfn domain) stream))
(tmp (make-array len :element-type '(unsigned-byte 8))))
(file-position stream off)
(read-sequence tmp stream)
(return (values tmp entry))))))))))
(defun domain-lookup (string domain)
(declare (type string string) (type domain-entry domain)
#+(or)(optimize (speed 3) (space 2) (safety 0)))
(or (if (null (domain-entry-encoding domain)) string)
(gethash string (domain-entry-hash domain))
(let* ((octets (string-to-octets string
(domain-entry-encoding domain)))
(length (length octets))
(pos (gethash length (domain-entry-hash domain))))
(declare (type (simple-array (unsigned-byte 8) (*)) octets))
(multiple-value-bind (tmp entry) (search-domain octets domain pos)
(declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
(when tmp
(let ((temp (delete entry pos :test #'eq)))
(if temp
(setf (gethash length (domain-entry-hash domain)) temp)
(remhash length (domain-entry-hash domain))))
(setf (gethash (copy-seq string) (domain-entry-hash domain))
(octets-to-string tmp (domain-entry-encoding domain))))))))
(defun domain-lookup-plural (singular plural domain)
(declare (type string singular plural) (type domain-entry domain)
#+(or)(optimize (speed 3) (space 2) (safety 0)))
(when (domain-entry-encoding domain)
(or (gethash (cons singular plural) (domain-entry-hash domain))
(let* ((octets (let* ((a (string-to-octets singular
(domain-entry-encoding domain)))
(b (string-to-octets plural
(domain-entry-encoding domain)))
(c (make-array (+ (length a) (length b) 1)
:element-type '(unsigned-byte 8))))
(declare (type (simple-array (unsigned-byte 8) (*))
a b c))
(replace c a)
(setf (aref c (length a)) 0)
(replace c b :start1 (+ (length a) 1))
c))
(length (length octets))
(pos (gethash length (domain-entry-hash domain))))
(declare (type (simple-array (unsigned-byte 8) (*)) octets)
(type list pos))
(multiple-value-bind (tmp entry) (search-domain octets domain pos)
(declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
(when tmp
(prog1
(setf (gethash (cons (copy-seq singular) (copy-seq plural))
(domain-entry-hash domain))
(loop for i = 0 then (1+ j)
as j = (position 0 tmp :start i)
collect (octets-to-string (subseq tmp i j)
(domain-entry-encoding domain))
while j))
(let ((temp (delete entry pos :test #'eq)))
(if temp
(setf (gethash length (domain-entry-hash domain)) temp)
(remhash length (domain-entry-hash domain))))
(when (null (domain-entry-plurals domain))
(setf (domain-entry-plurals domain)
(parse-plurals domain))))))))))
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
(declaim (inline getenv)
(ftype (function (string) (or null string)) getenv))
(defun getenv (var)
(let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD")
ext:*environment-list*))
#+SBCL (sb-ext:posix-getenv var)
#+Allegro (system:getenv var)
#+LispWorks (hcl:getenv var)
#+clisp (ext:getenv var)
#+(or openmcl mcl) (ccl::getenv var)
#+(or gcl ecl) (si::getenv var)))
(if (equal val "") nil val)))
(defun setlocale (&optional locale)
(setf *locale* (or locale
(getenv "LANGUAGE")
(getenv "LC_ALL")
(getenv "LC_MESSAGES")
(getenv "LANG")
*locale*)))
(defmacro textdomain (domain)
`(eval-when (:compile-toplevel :execute)
(setf *default-domain* ,domain)))
;; Set the textdomain to New-Domain for the body and then restore the
;; domain to the original.
(defmacro with-textdomain ((old-domain new-domain) &body body)
`(progn
(intl:textdomain ,new-domain)
,@body
(intl:textdomain ,old-domain)))
(defmacro gettext (string)
"Look up STRING in the current message domain and return its translation."
`(dgettext ,*default-domain* ,string))
(defmacro ngettext (singular plural n)
"Look up the singular or plural form of a message in the current domain."
`(dngettext ,*default-domain* ,singular ,plural ,n))
(declaim (inline dgettext))
(defun dgettext (domain string)
"Look up STRING in the specified message domain and return its translation."
#+(or)(declare (optimize (speed 3) (space 2) (safety 0)))
(let ((domain (and domain (find-domain domain *locale*))))
(or (and domain (domain-lookup string domain)) string)))
(defun dngettext (domain singular plural n)
"Look up the singular or plural form of a message in the specified domain."
(declare (type integer n)
#+(or)(optimize (speed 3) (space 2) (safety 0)))
(let* ((domain (and domain (find-domain domain *locale*)))
(list (and domain (domain-lookup-plural singular plural domain))))
(if list
(nth (the integer
(funcall (the function (domain-entry-plurals domain)) n))
list)
(if (= n 1) singular plural))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#-runtime
(defvar *translator-comment* nil)
#-runtime
(defvar *translations* nil)
#-runtime
(defun translation-enable ()
(setq *translations* (or *translations* (make-hash-table :test 'equal)))
t)
#-runtime
(defun translation-disable ()
(setq *translations* nil))
#-runtime
(defun note-translatable (domain string &optional plural)
(when (and domain *translations*)
(let* ((hash (or (gethash domain *translations*)
(setf (gethash domain *translations*)
(make-hash-table :test 'equal))))
(key (if plural (cons string plural) string))
(val (or (gethash key hash) (cons nil nil))))
(pushnew *translator-comment* (car val) :test #'equal)
(pushnew (and *compile-file-truename* (enough-namestring *compile-file-truename*))
(cdr val) :test #'equal)
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
;; FIXME: How does this happen? Need to figure this out and get
;; rid of this!
(unless key
(warn "Translate error with null key. domain = ~S string = ~S~%"
domain string))
(setf (gethash key hash) val)))
(setq *translator-comment* nil))
(define-compiler-macro dgettext (&whole form domain string)
#-runtime
(when (and (stringp domain) (stringp string))
(note-translatable domain string))
form)
(define-compiler-macro dngettext (&whole form domain singular plural n)
(declare (ignore n))
#-runtime
(when (and (stringp domain) (stringp singular) (stringp plural))
(note-translatable domain singular plural))
form)
(defun read-translatable-string (stream char)
(declare (ignore char))
(case (peek-char nil stream nil nil t)
(#\" (let* ((*read-suppress* nil)
(string (read stream t nil t)))
(note-translatable *default-domain* string)
`(gettext ,string)))
(#\N (read-char stream t nil t)
(let* ((*read-suppress* nil)
(string (read stream t nil t)))
#-runtime
(note-translatable *default-domain* string)
string))
(#\@ (error _"_@ is a reserved reader macro prefix."))
(otherwise
(let ((fn (get-macro-character #\_ nil)))
(if fn (funcall fn stream #\_) '_)))))
;; Process comments as usual, but look for lines that begin with
;; "TRANSLATORS: ". These lines are saved and written out as a
;; translator comment for the next translatable string.
#-runtime
(defun read-comment (stream char)
(declare (optimize (speed 0) (space 3) #-gcl (debug 0))
(ignore char))
(do ((state 0)
(index 0)
(text nil)
(char (read-char stream nil nil t) (read-char stream nil nil t)))
((or (not char) (char= char #\Newline))
(when text (setq *translator-comment* (copy-seq text))))
(cond ((and (= state 0) (char= char #\Space)) (setq state 1))
((and (= state 0) (char= char #\T)) (setq state 1 index 1))
((and (= state 0) (char/= char #\;)) (setq state 2))
((and (= state 1) (= index 0) (char= char #\Space)) #|ignore|#)
((= state 1)
(if (char= char (char "TRANSLATORS: " index))
(when (= (incf index) 13)
(setq state 3))
(setq state 2)))
((= state 3)
(when (null text)
(setq text (make-array 50 :element-type 'character
:adjustable t :fill-pointer 0)))
(vector-push-extend char text))))
(values))
#-runtime
(defun read-nested-comment (stream subchar arg)
(declare (ignore subchar arg)
(optimize (speed 0) (space 3) #-gcl (debug 0)))
(do ((level 1)
(state 0)
(index 0)
(text nil)
(prev (read-char stream t nil t) char)
(char (read-char stream t nil t) (read-char stream t nil t)))
(())
(cond ((and (char= prev #\|) (char= char #\#))
(when (zerop (decf level))
(when text
(setq *translator-comment*
(string-right-trim '(#\Space #\Newline) text)))
(return)))
((and (char= prev #\#) (char= char #\|))
(setq state 2)
(incf level))
((and (= state 0) (char= prev #\Space)) (setq state 1))
((and (= state 0) (char= prev #\T))
(setq state 1 index 1))
((= state 0) (setq state 2))
((and (= state 1) (= index 0) (char= prev #\Space)) #| ignore |#)
((= state 1)
(if (char= prev (char "TRANSLATORS: " index))
(when (= (incf index) 13)
(setq state 3))
(setq state 2)))
((= state 3)
(when (null text)
(setq text (make-array 50 :element-type 'character
:adjustable t :fill-pointer 0)))
(vector-push-extend prev text))))
(values))
(defun install (&optional (rt *readtable*))
(set-macro-character #\_ #'read-translatable-string t rt)
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
t)
;; Dump the translatable strings. The output is written to a file in
;; the directory OUTPUT-DIRECTORY and its name is the domain.
#-runtime
(defun dump-pot-files (&key copyright output-directory)
;;(declare (optimize (speed 0) (space 3) #-gcl (debug 1)))
(labels ((b (key data)
(format t "~@[~{~&#. ~A~}~%~]" (delete nil (car data)))
(format t "~@[~&~<#: ~@;~@{~A~^ ~}~:@>~%~]"
(delete nil (cdr data)))
(cond ((consp key)
(format t "~&msgid ") (str (car key) 6 0)
(format t "~&msgid_plural ") (str (cdr key) 13 0)
(format t "~&msgstr[0] \"\"~2%"))
(t
(cond
(key
(format t "~&msgid ") (str key 6 0)
(format t "~&msgstr \"\"~2%"))
(t
(format *error-output* "Skipping NIL key~%"))))))
(str (string col start)
(when (and (plusp col) (> (length string) (- 76 col)))
(format t "\"\"~%"))
(let ((nl (position #\Newline string :start start)))
(cond ((and nl (< (- nl start) 76))
(write-char #\")
(wstr string start nl)
(format t "\\n\"~%")
(str string 0 (1+ nl)))
((< (- (length string) start) 76)
(write-char #\")
(wstr string start (length string))
(write-char #\"))
(t
(let* ((a (+ start 1))
(b (+ start 76))
(b1 (position #\Space string :start a :end b
:from-end t))
(b2 (position-if (lambda (x)
(position x ";:,?!)]}"))
string :start a :end b
:from-end t))
(b3 (position-if (lambda (x)
(position x "\"'-"))
string :start a :end b
:from-end t))
(b4 (position-if #'digit-char-p
string :start a :end b
:from-end t))
(b5 (position-if #'alpha-char-p
string :start a :end b
:from-end t))
(g1 (if b1 (* (- b b1) (- b b1) .03) 10000))
(g2 (if b2 (* (- b b2) (- b b2) .20) 10000))
(g3 (if b3 (* (- b b3) (- b b3) .97) 10000))
(g4 (if b4 (* (- b b4) (- b b4) 1.3) 10000))
(g5 (if b5 (* (- b b5) (- b b5) 2.0) 10000))
(g (min g1 g2 g3 g4 g5))
(end (1+ (cond ((> g 750) b)
((= g g1) b1)
((= g g2) b2)
((= g g3) b3)
((= g g4) b4)
((= g g5) b5)))))
#+(or)
(progn
(format t "~&Splitting ~S:~%"
(subseq string start b))
(format t "~{~& b~D=~D; goodness=~F~}~%"
(list 1 b1 g1 2 b2 g2 3 b3 g3 4 b4 g4 5 b5 g5
6 b 10000))
(format t "~& best=~F == ~D~%" g end)
(format t "~& Part1=~S~% Part2=~S~%"
(subseq string start end)
(subseq string end b)))
(write-char #\")
(wstr string start end)
(write-char #\") (terpri)
(str string 0 end))))))
(wstr (string start end)
(loop while (< start end) do
(let ((i (position-if (lambda (x)
(or (char= x #\") (char= x #\\)))
string :start start :end end)))
(write-string string nil :start start :end (or i end))
(when i (write-char #\\ nil) (write-char (char string i) nil))
(setq start (if i (1+ i) end)))))
(a (domain hash)
(format t _"~&Dumping ~D messages for domain ~S~%"
(hash-table-count hash) domain)
(with-open-file (*standard-output*
(merge-pathnames (make-pathname :name domain
:type "pot")
output-directory)
:direction :output
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
:external-format :iso8859-1
)
(format t "~&#@ ~A~2%" domain)
(format t "~&# SOME DESCRIPTIVE TITLE~%")
(format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright)
(format t "~&# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR~%")
(format t "~&#~%#, fuzzy~%msgid \"\"~%msgstr \"\"~%")
(format t "~&\"Project-Id-Version: PACKAGE VERSION\\n\"~%")
(format t "~&\"Report-Msgid-Bugs-To: \\n\"~%")
(format t "~&\"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"~%")
(format t "~&\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"~%")
(format t "~&\"Language-Team: LANGUAGE <LL@li.org>\\n\"~%")
(format t "~&\"MIME-Version: 1.0\\n\"~%")
(format t "~&\"Content-Type: text/plain; charset=UTF-8\\n\"~%")
(format t "~&\"Content-Transfer-Encoding: 8bit\\n\"~2%")
(maphash #'b hash))))
(maphash #'a *translations*)
#+(or)
(clrhash *translations*))
nil)
(eval-when (:compile-toplevel :execute)
(setq *default-domain* nil)
(unless (and (fboundp 'intl:read-translatable-string)
(eq (get-macro-character #\_)
(fdefinition 'intl:read-translatable-string)))
(set-syntax-from-char #\_ #\_)))
;; Don't install the reader macros by default.
#+(or)
(install)