src/intl.lisp

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