CMUCL commit: intl-branch src (6 files)
Raymond Toy
rtoy at common-lisp.net
Mon Feb 8 03:49:49 CET 2010
Date: Sunday, February 7, 2010 @ 21:49:49
Author: rtoy
Path: /project/cmucl/cvsroot/src
Tag: intl-branch
Added: bootfiles/20a/boot-2010-02-1.lisp code/intl.lisp
Modified: code/exports.lisp tools/worldbuild.lisp tools/worldcom.lisp
tools/worldload.lisp
Add support for localization. From Paul Foley.
bootfiles/20a/boot-2010-02-1.lisp:
o New file to bootstrap localization support.
code/intl.lisp:
o New file that implements localization.
code/exports.lisp:
o Define INTL package
o Add INTL package to LISP
tools/worldbuild.lisp
tools/worldcom.lisp
tools/worldload.lisp
o Compile intl.lisp
-----------------------------------+
bootfiles/20a/boot-2010-02-1.lisp | 11
code/exports.lisp | 10
code/intl.lisp | 772 ++++++++++++++++++++++++++++++++++++
tools/worldbuild.lisp | 2
tools/worldcom.lisp | 4
tools/worldload.lisp | 5
6 files changed, 799 insertions(+), 5 deletions(-)
Index: src/bootfiles/20a/boot-2010-02-1.lisp
diff -u /dev/null src/bootfiles/20a/boot-2010-02-1.lisp:1.1.2.1
--- /dev/null Sun Feb 7 21:49:49 2010
+++ src/bootfiles/20a/boot-2010-02-1.lisp Sun Feb 7 21:49:48 2010
@@ -0,0 +1,11 @@
+;; Bootstrap file for adding support for localization.
+(defpackage "INTL"
+ (:use "COMMON-LISP")
+ (:export "SETLOCALE" "TEXTDOMAIN" "GETTEXT" "DGETTEXT" "NGETTEXT" "DNGETTEXT"
+ "*TRANSLATABLE-DUMP-STREAM*" "READ-TRANSLATABLE-STRING"
+ "*LOCALE-DIRECTORIES*"))
+
+(with-open-file (s "target:code/intl.lisp")
+ (compile-from-stream s))
+
+(intl::install)
Index: src/code/exports.lisp
diff -u src/code/exports.lisp:1.293 src/code/exports.lisp:1.293.2.1
--- src/code/exports.lisp:1.293 Sat Feb 6 23:28:24 2010
+++ src/code/exports.lisp Sun Feb 7 21:49:49 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.293 2010-02-07 04:28:24 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.293.2.1 2010-02-08 02:49:49 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -588,8 +588,14 @@
"WRITE-SEQUENCE" "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P"
"ZEROP"))
+(defpackage "INTL"
+ (:use "COMMON-LISP")
+ (:export "SETLOCALE" "TEXTDOMAIN" "GETTEXT" "DGETTEXT" "NGETTEXT" "DNGETTEXT"
+ "*TRANSLATABLE-DUMP-STREAM*" "READ-TRANSLATABLE-STRING"
+ "*LOCALE-DIRECTORIES*"))
+
(defpackage "LISP"
- (:use "COMMON-LISP" "EXTENSIONS" "KERNEL" "SYSTEM" "DEBUG" "BIGNUM")
+ (:use "COMMON-LISP" "EXTENSIONS" "KERNEL" "SYSTEM" "DEBUG" "BIGNUM" "INTL")
(:shadowing-import-from
"COMMON-LISP" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS"
"CLASS-OF" "FIND-CLASS")
Index: src/code/intl.lisp
diff -u /dev/null src/code/intl.lisp:1.1.2.1
--- /dev/null Sun Feb 7 21:49:49 2010
+++ src/code/intl.lisp Sun Feb 7 21:49:49 2010
@@ -0,0 +1,772 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
+
+;;; $Revision: 1.1.2.1 $
+;;; Copyright 1999-2010 Paul Foley (mycroft at 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.
+#+CMU (ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/Attic/intl.lisp,v 1.1.2.1 2010-02-08 02:49:49 rtoy Exp $")
+
+(in-package "INTL")
+
+(eval-when (:compile-toplevel :execute)
+ (defparameter intl::*default-domain* "libintl")
+ (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
+ _N"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 (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 (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)
+ (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) :iso-8859-1)
+ (let* ((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 _"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 _"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 _"Expected : in ?: construct"))
+ (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 _"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 _"Unexpected token: ~S." tok)))))
+ (multiple-value-bind (tree end) (conditional (next))
+ (unless (eq end 'END)
+ (error _"Expecting end of expression. ~S." end))
+ (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 (return-from load-domain nil))
+ (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
+ (error _"Bad magic number in \"~A.mo\"." domain))))
+ (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)
+ (optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)))
+ (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)
+ (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)
+ (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)
+ (optimize (speed 3) (space 2) (safety 0)))
+ (or (if (null (domain-entry-encoding domain)) nil)
+ (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)))))))))
+
+(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)))
+
+(defmacro gettext (string)
+ _N"Look up STRING in the current message domain and return its translation."
+ `(dgettext ,*default-domain* ,string))
+
+(defmacro ngettext (singular plural n)
+ _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)
+ _N"Look up STRING in the specified message domain and return its translation."
+ (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)
+ _N"Look up the singular or plural form of a message in the specified domain."
+ (declare (type integer n)
+ (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* (make-hash-table :test 'equal))
+
+#-runtime
+(defun note-translatable (domain string &optional plural)
+ (when domain
+ (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 *compile-file-pathname* (cdr val) :test #'equal)
+ (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)))
+ `(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 #\_) '_)))))
+
+#-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 ()
+ (set-macro-character #\_ #'read-translatable-string t)
+ #-runtime
+ (set-macro-character #\; #'read-comment)
+ #-runtime
+ (set-dispatch-macro-character #\# #\| #'read-nested-comment)
+ t)
+
+
+#-runtime
+(defun dump-pot-files (&key copyright)
+ (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
+ (format t "~&msgid ") (str key 6 0)
+ (format t "~&msgstr \"\"~2%"))))
+ (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 "~&#@ ~A~2%" domain)
+ (format t "~&# SOME DESCRIPTIVE TITLE~%")
+ (format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright)
+ (format t "~&# FIRST AUTHOR <EMAIL at 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 at ADDRESS>\\n\"~%")
+ (format t "~&\"Language-Team: LANGUAGE <LL at 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 #\_ #\_)))
+
+(install)
\ No newline at end of file
Index: src/tools/worldbuild.lisp
diff -u src/tools/worldbuild.lisp:1.55 src/tools/worldbuild.lisp:1.55.10.1
--- src/tools/worldbuild.lisp:1.55 Thu Jun 18 13:39:45 2009
+++ src/tools/worldbuild.lisp Sun Feb 7 21:49:49 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/tools/worldbuild.lisp,v 1.55 2009-06-18 17:39:45 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/tools/worldbuild.lisp,v 1.55.10.1 2010-02-08 02:49:49 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
Index: src/tools/worldcom.lisp
diff -u src/tools/worldcom.lisp:1.102 src/tools/worldcom.lisp:1.102.10.1
--- src/tools/worldcom.lisp:1.102 Thu Jun 18 13:39:45 2009
+++ src/tools/worldcom.lisp Sun Feb 7 21:49:49 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/tools/worldcom.lisp,v 1.102 2009-06-18 17:39:45 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/tools/worldcom.lisp,v 1.102.10.1 2010-02-08 02:49:49 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -318,6 +318,8 @@
(comf "target:code/macros")
#-no-runtime (comf "target:code/macros" :byte-compile t))
+(comf "target:code/intl")
+
); let *byte-compile-top-level*
); with-compiler-log-file
Index: src/tools/worldload.lisp
diff -u src/tools/worldload.lisp:1.110 src/tools/worldload.lisp:1.110.12.1
--- src/tools/worldload.lisp:1.110 Thu Jun 11 12:04:02 2009
+++ src/tools/worldload.lisp Sun Feb 7 21:49:49 2010
@@ -6,7 +6,7 @@
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
-;;; $Header: /project/cmucl/cvsroot/src/tools/worldload.lisp,v 1.110 2009-06-11 16:04:02 rtoy Rel $
+;;; $Header: /project/cmucl/cvsroot/src/tools/worldload.lisp,v 1.110.12.1 2010-02-08 02:49:49 rtoy Exp $
;;;
;;; **********************************************************************
;;;
@@ -164,6 +164,9 @@
#+(and unicode (not (or unicode-bootstrap no-compiler runtime)))
(maybe-byte-load "code:fd-stream-extfmt")
+(maybe-byte-load "target:code/intl")
+
+
;;; PCL.
;;;
#-(or no-pcl runtime) (maybe-byte-load "pcl:pclload")
More information about the cmucl-commit
mailing list