CMUCL commit: intl-branch src/code (intl.lisp)

Raymond Toy rtoy at common-lisp.net
Fri Feb 12 01:37:01 CET 2010


    Date: Thursday, February 11, 2010 @ 19:37:01
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/code
     Tag: intl-branch

Modified: intl.lisp

o Turn off optimization properties for now.
o Fix issue where we run into trouble doing a domain lookup.  This can
  call the compiler, which might want to look up translations, which
  calls for a domain lookup and so on.  We fix it by binding *locale*
  to "C" in FIND-ENCODING.
o Don't translate the error message about bad magic numbers.  Also,
  change the error to a warning and return NIL.  I think otherwise we
  get in an infinite loop trying to find a domain to print the
  translated error message.
o Fix OCTETS= to handle the case where start1/start2 is not less than
  end1/end2.  This happens when we do a domain lookup for "" to
  determine the encoding.


-----------+
 intl.lisp |   56 +++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 33 insertions(+), 23 deletions(-)


Index: src/code/intl.lisp
diff -u src/code/intl.lisp:1.1.2.9 src/code/intl.lisp:1.1.2.10
--- src/code/intl.lisp:1.1.2.9	Wed Feb 10 12:26:43 2010
+++ src/code/intl.lisp	Thu Feb 11 19:37:00 2010
@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
 
-;;; $Revision: 1.1.2.9 $
+;;; $Revision: 1.1.2.10 $
 ;;; Copyright 1999-2010 Paul Foley (mycroft at actrix.gen.nz)
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person obtaining
@@ -23,7 +23,7 @@
 ;;; (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: /project/cmucl/cvsroot/src/code/Attic/intl.lisp,v 1.1.2.9 2010-02-10 17:26:43 rtoy Exp $")
+(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/Attic/intl.lisp,v 1.1.2.10 2010-02-12 00:37:00 rtoy Exp $")
 
 (in-package "INTL")
 
@@ -63,7 +63,7 @@
 
 (declaim (ftype (function (stream) (unsigned-byte 32)) read-lelong))
 (defun read-lelong (stream)
-  (declare (optimize (speed 3) (space 2) (safety 0)
+  (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)
@@ -72,7 +72,7 @@
 
 (declaim (ftype (function (stream) (unsigned-byte 32)) read-belong))
 (defun read-belong (stream)
-  (declare (optimize (speed 3) (space 2) (safety 0)
+  (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)
@@ -106,7 +106,10 @@
 (defun find-encoding (domain)
   (when (null (domain-entry-encoding domain))
     (setf (domain-entry-encoding domain) :iso-8859-1)
-    (let* ((header (domain-lookup "" domain))
+    ;; 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
@@ -326,7 +329,12 @@
 	(cond ((= magic #x950412de) (setq read #'read-lelong))
 	      ((= magic #xde120495) (setq read #'read-belong))
 	      (t
-	       (error _"Bad magic number in \"~A.mo\"." domain))))
+	       ;; 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))
@@ -389,16 +397,18 @@
 			 (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))))
+	   #+(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)
-	   (optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0)
+	   #+(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)))
@@ -413,14 +423,14 @@
 				    :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))))))
+			 :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))
@@ -432,7 +442,7 @@
 
 (defun domain-lookup (string domain)
   (declare (type string string) (type domain-entry domain)
-	   (optimize (speed 3) (space 2) (safety 0)))
+	   #+(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
@@ -452,7 +462,7 @@
 
 (defun domain-lookup-plural (singular plural domain)
   (declare (type string singular plural) (type domain-entry domain)
-	   (optimize (speed 3) (space 2) (safety 0)))
+	   #+(or)(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
@@ -526,14 +536,14 @@
 (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)))
+  #+(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)
   _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)))
+	   #+(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



More information about the cmucl-commit mailing list