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

Diff of /src/code/intl.lisp

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

revision 1.1.2.10 by rtoy, Fri Feb 12 00:37:00 2010 UTC revision 1.11 by rtoy, Sun Dec 19 03:01:47 2010 UTC
# Line 47  Line 47 
47  (defvar *locale* "C")  (defvar *locale* "C")
48    
49  (defvar *default-domain* nil  (defvar *default-domain* nil
50    _N"The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT.    "The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT.
51    Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.")    Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.")
52  (defvar *loaded-domains* (make-hash-table :test 'equal))  (defvar *loaded-domains* (make-hash-table :test 'equal))
53  (defvar *locale-aliases* (make-hash-table :test 'equal))  (defvar *locale-aliases* (make-hash-table :test 'equal))
# Line 166  Line 166 
166                          'LOGAND))                          'LOGAND))
167                 (#\= (if (char= (char string pos) #\=)                 (#\= (if (char= (char string pos) #\=)
168                          (progn (incf pos) 'CMP=)                          (progn (incf pos) 'CMP=)
169                          (error _"Encountered illegal token: =")))                          (error (intl:gettext "Encountered illegal token: ="))))
170                 (#\! (if (char= (char string pos) #\=)                 (#\! (if (char= (char string pos) #\=)
171                          (progn (incf pos) 'CMP/=)                          (progn (incf pos) 'CMP/=)
172                          'NOT))                          'NOT))
# Line 184  Line 184 
184                                        while nx                                        while nx
185                                     do (setq n (+ (* n 10) nx)) (incf pos)                                     do (setq n (+ (* n 10) nx)) (incf pos)
186                                     finally (return n))                                     finally (return n))
187                                  (error _"Encountered illegal token: ~C"                                  (error (intl:gettext "Encountered illegal token: ~C")
188                                         (char string (1- pos))))))))                                         (char string (1- pos))))))))
189             (conditional (tok &aux tree)             (conditional (tok &aux tree)
190               (multiple-value-setq (tree tok) (logical-or tok))               (multiple-value-setq (tree tok) (logical-or tok))
191               (when (eql tok 'IF)               (when (eql tok 'IF)
192                 (multiple-value-bind (right next) (logical-or (next))                 (multiple-value-bind (right next) (logical-or (next))
193                   (unless (eql next 'THEN)                   (unless (eql next 'THEN)
194                     (error _"Expected : in ?: construct"))                     (error (intl:gettext "Expected : in ?: construct")))
195                   (multiple-value-bind (else next) (conditional (next))                   (multiple-value-bind (else next) (conditional (next))
196                     (setq tree (list tok (list 'zerop tree) else right)                     (setq tree (list tok (list 'zerop tree) else right)
197                           tok next))))                           tok next))))
# Line 270  Line 270 
270               (cond ((eq tok 'LPAR)               (cond ((eq tok 'LPAR)
271                      (multiple-value-setq (tree tok) (conditional (next)))                      (multiple-value-setq (tree tok) (conditional (next)))
272                      (unless (eq tok 'RPAR)                      (unless (eq tok 'RPAR)
273                        (error _"Expected close-paren."))                        (error (intl:gettext "Expected close-paren.")))
274                      (values tree (next)))                      (values tree (next)))
275                     ((numberp tok)                     ((numberp tok)
276                      (values tok (next)))                      (values tok (next)))
# Line 288  Line 288 
288                      (multiple-value-setq (tree tok) (unary (next)))                      (multiple-value-setq (tree tok) (unary (next)))
289                      (values (list 'CNOT tree) tok))                      (values (list 'CNOT tree) tok))
290                     (t                     (t
291                      (error _"Unexpected token: ~S." tok)))))                      (error (intl:gettext "Unexpected token: ~S.") tok)))))
292      (multiple-value-bind (tree end) (conditional (next))      (multiple-value-bind (tree end) (conditional (next))
293        (unless (eq end 'END)        (unless (eq end 'END)
294          (error _"Expecting end of expression.  ~S." end))          (error (intl:gettext "Expecting end of expression.  ~S.") end))
295        (let ((*compile-print* nil))        (let ((*compile-print* nil))
296          (compile nil          (compile nil
297                   `(lambda (n)                   `(lambda (n)
# Line 321  Line 321 
321  (defun load-domain (domain locale &optional (locale-dir *locale-directories*))  (defun load-domain (domain locale &optional (locale-dir *locale-directories*))
322    (let ((file (locate-domain-file domain locale locale-dir))    (let ((file (locate-domain-file domain locale locale-dir))
323          (read #'read-lelong))          (read #'read-lelong))
324      (unless file (return-from load-domain nil))      (unless file
325          (let ((entry (make-domain-entry :domain domain :locale locale
326                                          :hash (make-hash-table :size 0
327                                                                 :test 'equal))))
328            (setf (gethash domain *loaded-domains*) entry)
329            (return-from load-domain entry)))
330      (with-open-file (stream file :direction :input :if-does-not-exist nil      (with-open-file (stream file :direction :input :if-does-not-exist nil
331                              :element-type '(unsigned-byte 8))                              :element-type '(unsigned-byte 8))
332        (unless stream (return-from load-domain nil))        (unless stream (return-from load-domain nil))
# Line 463  Line 468 
468  (defun domain-lookup-plural (singular plural domain)  (defun domain-lookup-plural (singular plural domain)
469    (declare (type string singular plural) (type domain-entry domain)    (declare (type string singular plural) (type domain-entry domain)
470             #+(or)(optimize (speed 3) (space 2) (safety 0)))             #+(or)(optimize (speed 3) (space 2) (safety 0)))
471    (or (if (null (domain-entry-encoding domain)) nil)    (when (domain-entry-encoding domain)
472        (gethash (cons singular plural) (domain-entry-hash domain))      (or (gethash (cons singular plural) (domain-entry-hash domain))
473        (let* ((octets (let* ((a (string-to-octets singular          (let* ((octets (let* ((a (string-to-octets singular
474                                                 (domain-entry-encoding domain)))                                                     (domain-entry-encoding domain)))
475                              (b (string-to-octets plural                                (b (string-to-octets plural
476                                                 (domain-entry-encoding domain)))                                                     (domain-entry-encoding domain)))
477                              (c (make-array (+ (length a) (length b) 1)                                (c (make-array (+ (length a) (length b) 1)
478                                             :element-type '(unsigned-byte 8))))                                               :element-type '(unsigned-byte 8))))
479                         (declare (type (simple-array (unsigned-byte 8) (*))                           (declare (type (simple-array (unsigned-byte 8) (*))
480                                        a b c))                                          a b c))
481                         (replace c a)                           (replace c a)
482                         (setf (aref c (length a)) 0)                           (setf (aref c (length a)) 0)
483                         (replace c b :start1 (+ (length a) 1))                           (replace c b :start1 (+ (length a) 1))
484                         c))                           c))
485               (length (length octets))                 (length (length octets))
486               (pos (gethash length (domain-entry-hash domain))))                 (pos (gethash length (domain-entry-hash domain))))
487          (declare (type (simple-array (unsigned-byte 8) (*)) octets)            (declare (type (simple-array (unsigned-byte 8) (*)) octets)
488                   (type list pos))                     (type list pos))
489          (multiple-value-bind (tmp entry) (search-domain octets domain pos)            (multiple-value-bind (tmp entry) (search-domain octets domain pos)
490            (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))              (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp))
491            (when tmp              (when tmp
492              (prog1                (prog1
493                  (setf (gethash (cons (copy-seq singular) (copy-seq plural))                    (setf (gethash (cons (copy-seq singular) (copy-seq plural))
494                                 (domain-entry-hash domain))                                   (domain-entry-hash domain))
495                      (loop for i = 0 then (1+ j)                          (loop for i = 0 then (1+ j)
496                             as j = (position 0 tmp :start i)                             as j = (position 0 tmp :start i)
497                        collect (octets-to-string (subseq tmp i j)                             collect (octets-to-string (subseq tmp i j)
498                                                  (domain-entry-encoding domain))                                                       (domain-entry-encoding domain))
499                        while j))                             while j))
500                (let ((temp (delete entry pos :test #'eq)))                  (let ((temp (delete entry pos :test #'eq)))
501                  (if temp                    (if temp
502                      (setf (gethash length (domain-entry-hash domain)) temp)                        (setf (gethash length (domain-entry-hash domain)) temp)
503                      (remhash length (domain-entry-hash domain))))                        (remhash length (domain-entry-hash domain))))
504                (when (null (domain-entry-plurals domain))                  (when (null (domain-entry-plurals domain))
505                  (setf (domain-entry-plurals domain)                    (setf (domain-entry-plurals domain)
506                      (parse-plurals domain)))))))))                          (parse-plurals domain))))))))))
507    
508  (declaim (inline getenv)  (declaim (inline getenv)
509           (ftype (function (string) (or null string)) getenv))           (ftype (function (string) (or null string)) getenv))
# Line 525  Line 530 
530    `(eval-when (:compile-toplevel :execute)    `(eval-when (:compile-toplevel :execute)
531       (setf *default-domain* ,domain)))       (setf *default-domain* ,domain)))
532    
533    ;; Set the textdomain to New-Domain for the body and then restore the
534    ;; domain to the original.
535    (defmacro with-textdomain ((old-domain new-domain) &body body)
536      `(progn
537         (intl:textdomain ,new-domain)
538         ,@body
539         (intl:textdomain ,old-domain)))
540    
541  (defmacro gettext (string)  (defmacro gettext (string)
542    _N"Look up STRING in the current message domain and return its translation."    "Look up STRING in the current message domain and return its translation."
543    `(dgettext ,*default-domain* ,string))    `(dgettext ,*default-domain* ,string))
544    
545  (defmacro ngettext (singular plural n)  (defmacro ngettext (singular plural n)
546    _N"Look up the singular or plural form of a message in the current domain."    "Look up the singular or plural form of a message in the current domain."
547    `(dngettext ,*default-domain* ,singular ,plural ,n))    `(dngettext ,*default-domain* ,singular ,plural ,n))
548    
549  (declaim (inline dgettext))  (declaim (inline dgettext))
550  (defun dgettext (domain string)  (defun dgettext (domain string)
551    _N"Look up STRING in the specified message domain and return its translation."    "Look up STRING in the specified message domain and return its translation."
552    #+(or)(declare (optimize (speed 3) (space 2) (safety 0)))    #+(or)(declare (optimize (speed 3) (space 2) (safety 0)))
553    (let ((domain (and domain (find-domain domain *locale*))))    (let ((domain (and domain (find-domain domain *locale*))))
554      (or (and domain (domain-lookup string domain)) string)))      (or (and domain (domain-lookup string domain)) string)))
555    
556  (defun dngettext (domain singular plural n)  (defun dngettext (domain singular plural n)
557    _N"Look up the singular or plural form of a message in the specified domain."    "Look up the singular or plural form of a message in the specified domain."
558    (declare (type integer n)    (declare (type integer n)
559             #+(or)(optimize (speed 3) (space 2) (safety 0)))             #+(or)(optimize (speed 3) (space 2) (safety 0)))
560    (let* ((domain (and domain (find-domain domain *locale*)))    (let* ((domain (and domain (find-domain domain *locale*)))
# Line 558  Line 571 
571  (defvar *translator-comment* nil)  (defvar *translator-comment* nil)
572    
573  #-runtime  #-runtime
574  (defvar *translations* (make-hash-table :test 'equal))  (defvar *translations* nil)
575    
576    #-runtime
577    (defun translation-enable ()
578      (setq *translations* (or *translations* (make-hash-table :test 'equal)))
579      t)
580    
581    #-runtime
582    (defun translation-disable ()
583      (setq *translations* nil))
584    
585  #-runtime  #-runtime
586  (defun note-translatable (domain string &optional plural)  (defun note-translatable (domain string &optional plural)
587    (when domain    (when (and domain *translations*)
588      (let* ((hash (or (gethash domain *translations*)      (let* ((hash (or (gethash domain *translations*)
589                       (setf (gethash domain *translations*)                       (setf (gethash domain *translations*)
590                             (make-hash-table :test 'equal))))                             (make-hash-table :test 'equal))))
591             (key (if plural (cons string plural) string))             (key (if plural (cons string plural) string))
592             (val (or (gethash key hash) (cons nil nil))))             (val (or (gethash key hash) (cons nil nil))))
593        (pushnew *translator-comment* (car val) :test #'equal)        (pushnew *translator-comment* (car val) :test #'equal)
594        (pushnew *compile-file-pathname* (cdr val) :test #'equal)        (pushnew (and *compile-file-truename* (enough-namestring *compile-file-truename*))
595                   (cdr val) :test #'equal)
596        ;; FIXME: How does this happen?  Need to figure this out and get        ;; FIXME: How does this happen?  Need to figure this out and get
597        ;; rid of this!        ;; rid of this!
598        (unless key        (unless key
# Line 596  Line 619 
619      (case (peek-char nil stream nil nil t)      (case (peek-char nil stream nil nil t)
620        (#\" (let* ((*read-suppress* nil)        (#\" (let* ((*read-suppress* nil)
621                    (string (read stream t nil t)))                    (string (read stream t nil t)))
              #-runtime  
622               (note-translatable *default-domain* string)               (note-translatable *default-domain* string)
623               `(gettext ,string)))               `(gettext ,string)))
624        (#\N (read-char stream t nil t)        (#\N (read-char stream t nil t)
# Line 676  Line 698 
698             (vector-push-extend prev text))))             (vector-push-extend prev text))))
699    (values))    (values))
700    
701  (defun install ()  (defun install (&optional (rt *readtable*))
702    (set-macro-character #\_ #'read-translatable-string t)    (set-macro-character #\_ #'read-translatable-string t rt)
703    #-runtime    #-runtime
704    (set-macro-character #\; #'read-comment)    (set-macro-character #\; #'read-comment nil rt)
705    #-runtime    #-runtime
706    (set-dispatch-macro-character #\# #\| #'read-nested-comment)    (set-dispatch-macro-character #\# #\| #'read-nested-comment rt)
707    t)    t)
708    
709    
# Line 812  Line 834 
834                     (fdefinition 'intl:read-translatable-string)))                     (fdefinition 'intl:read-translatable-string)))
835      (set-syntax-from-char #\_ #\_)))      (set-syntax-from-char #\_ #\_)))
836    
 (install)  
837    ;; Don't install the reader macros by default.
838    #+(or)
839    (install)

Legend:
Removed from v.1.1.2.10  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5