Changeset 15236


Ignore:
Timestamp:
Mar 9, 2012, 1:49:25 AM (7 years ago)
Author:
gb
Message:

Change the initial-values *TERMINAL-CHARACTER-ENCODING-NAME* and
*DEFAULT-FILE-CHARACTER-ENCODING* to :UTF-8, mostly for the benefit of
the Init-File-Editing-Impaired. (I've resolved not to make fun of
the IFEI.) Note that this may require changes to startup scripts etc.

Define new conditions CCL:DECODING-PROBLEM and CCL:ENCODING-PROBLEM.
Signal these conditions (via SIGNAL) when decoding characters
from/enoding them to a stream, pointer or octet vector and a substitution
or replacement character would be used.

New macros (CCL:WITH-DECODING-PROBLEMS-AS-ERRORS &body body) and
(CCL:WITH-ENCODING-PROBLEMS-AS-ERRORS &body body) signal the corresponding
conditions as ERRORs if they are signaled during execution of the body.

(Arguably) fixes ticket:749.

FILE-STRING-LENGTH checks to see if the encoding wants to use a
byte-order-mark before subtracting the length of an encoded BOM
from the encoded string length if the file is at its beginning.

Location:
trunk/source
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-io.lisp

    r13067 r15236  
    162162                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
    163163                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
    164         (setf (schar string i) (or char #\Replacement_Character))))))
     164        (setf (schar string i) (or char (note-vector-decoding-problem pointer index :utf-8)))))))
    165165
    166166(defun utf-8-length-of-memory-encoding (pointer noctets start)
  • trunk/source/level-1/l1-error-system.lisp

    r15018 r15236  
    5151  ((kill :initarg :kill :initform nil :reader process-reset-kill)))
    5252
     53(define-condition encoding-problem (condition)
     54  ((character :initarg :character :reader encoding-problem-character)
     55   (destination :initarg :destination :reader encoding-problem-destination)
     56   (encoding-name :initarg :encoding-name :reader encoding-problem-encoding-name))
     57  (:report
     58   (lambda (c s)
     59     (with-slots (character destination encoding-name) c
     60       (format s "Character ~c can't be written to ~a in encoding ~a."
     61               character destination encoding-name)))))
     62
     63
     64
     65(define-condition decoding-problem (condition)
     66  ((source :initarg :source :reader decoding-problem-source)
     67   (position :initarg :position :reader decoding-problem-position)
     68   (encoding-name :initarg :encoding-name :reader decoding-problem-encoding-name))
     69  (:report (lambda (c stream)
     70             (with-slots (source position encoding-name) c
     71               (format stream "Contents of ~a" source)
     72               (when position
     73                 (format stream ", near ~a ~d," (if (typep source 'stream) "positition" "index") position))
     74               (format stream " don't represent a valid character in ~s." encoding-name)))))
     75
     76
     77             
    5378
    5479(define-condition print-not-readable (error)
  • trunk/source/level-1/l1-init.lisp

    r14362 r15236  
    313313
    314314
    315 (defvar *terminal-character-encoding-name* nil
     315(defvar *terminal-character-encoding-name* :utf-8
    316316  "NIL (implying :ISO-8859-1), or a keyword which names a defined
    317317character encoding to be used for *TERMINAL-IO* and other predefined
  • trunk/source/level-1/l1-sysio.lisp

    r15165 r15236  
    8585(defvar *default-external-format* :unix)
    8686
    87 (defvar *default-file-character-encoding* nil)
     87(defvar *default-file-character-encoding* :utf-8)
    8888
    8989(defmethod default-character-encoding ((domain (eql :file)))
     
    932932                   (file-string-length stream #\Return))
    933933                0))
    934            (if (eql (file-position stream) 0)
    935              0
    936              (length (character-encoding-bom-encoding encoding)))))))))
     934           (if (and (eql (file-position stream) 0)
     935                    (character-encoding-use-byte-order-mark encoding))
     936             (length (character-encoding-bom-encoding encoding))
     937             0)))))))
    937938 
  • trunk/source/level-1/l1-unicode.lisp

    r14364 r15236  
    154154    (format stream "~a" (character-encoding-name ce))))
    155155
     156(defun note-stream-decoding-problem (stream)
     157  (let* ((source (if (typep stream 'ioblock)
     158                   (ioblock-stream stream)
     159                   stream))
     160         (position (stream-position source))
     161         (encoding-name
     162          (character-encoding-name
     163           (external-format-character-encoding (stream-external-format source)))))
     164    (signal (make-condition 'decoding-problem
     165                            :source source
     166                            :position position
     167                            :encoding-name encoding-name))
     168    #\Replacement_Character))
     169
     170(defun note-vector-decoding-problem (vector index encoding)
     171  (signal (make-condition 'decoding-problem
     172                          :source vector
     173                          :position index
     174                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
     175                                                       encoding
     176                                                       (lookup-character-encoding encoding))))
     177                                           (if enc (character-encoding-name enc) encoding))))
     178  #\Replacement_Character)
     179
     180(defun note-encoding-problem (char destination encoding code)
     181  (signal (make-condition 'encoding-problem
     182                          :character char
     183                          :destination (if (typep destination 'ioblock)
     184                                         (ioblock-stream destination)
     185                                         destination)
     186                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
     187                                                       encoding
     188                                                       (lookup-character-encoding encoding))))
     189                                           (if enc (character-encoding-name enc) encoding))))
     190  code)
     191                         
    156192;;; N.B.  (ccl:nfunction <name> (lambda (...) ...)) is just  like
    157193;;;       (cl:function (lambda (...) ...)), except that the resulting
     
    205241       (declare (type (mod #x110000) code))
    206242       (if (>= code 256)
    207          (setq code (char-code #\Sub)))
     243         (setq code (note-encoding-problem char stream :iso-8859-1 (char-code #\Sub))))
    208244       (funcall write-function stream code)
    209245       1)))
     
    227263         (declare (type (mod #x110000) code))
    228264         (if (>= code 256)
    229            (setq code (char-code #\Sub)))
     265           (setq code (note-encoding-problem char vector :iso-8859-1 (char-code #\Sub))))
    230266         (progn
    231267           (setf (aref vector idx) code)
     
    247283     (do* ((i start (1+ i)))
    248284          ((>= i end) idx)
    249        (let* ((code (char-code (schar string i))))
     285       (let* ((char (schar string i))
     286              (code (char-code char)))
    250287         (declare (type (mod #x110000) code))
    251288         (if (>= code 256)
    252            (setq code (char-code #\Sub)))
     289           (setq code (note-encoding-problem char pointer :iso-8859-1 (char-code #\Sub))))
    253290         (setf (%get-unsigned-byte pointer idx) code)
    254291         (incf idx)))))
     
    270307  :decode-literal-code-unit-limit 256
    271308  :encode-literal-char-code-limit 256
     309
    272310  )
    273311
     
    284322       (declare (type (mod #x110000) code))
    285323       (when (>= code 128)
    286          (setq code (char-code #\Sub)))
     324         (setq code (note-encoding-problem char stream :us-ascii (char-code #\Sub))))
    287325       (funcall write-function stream code)
    288326       1)))
     
    291329   ascii-stream-decode
    292330   (lambda (1st-unit next-unit-function stream)
    293      (declare (ignore next-unit-function stream)
     331     (declare (ignore next-unit-function)
    294332              (type (unsigned-byte 8) 1st-unit))
    295333     (if (< 1st-unit 128)
    296334       (code-char 1st-unit)
    297        #\Replacement_Character)))
     335       (note-stream-decoding-problem stream))))
    298336  :vector-encode-function
    299337  (nfunction
     
    308346         (declare (type (mod #x110000) code))
    309347         (if (>= code 128)
    310            (setq code (char-code #\Sub)))
     348           (setq code (note-encoding-problem char vector :us-ascii (char-code #\Sub))))
    311349         (setf (aref vector idx) code)
    312350         (incf idx)))))
     
    321359       (let* ((code (aref vector index)))
    322360         (declare (type (unsigned-byte 8) code))
    323          (when (>= code 128)
    324            (setq code (char-code #\Sub)))
    325          (setf (schar string i) (code-char code))))))
     361         (setf (schar string i) (if (< code 128)
     362                                  (code-char code)
     363                                  (note-vector-decoding-problem vector index :us-ascii)))))))
    326364  :memory-encode-function
    327365  (nfunction
     
    330368     (do* ((i start (1+ i)))
    331369          ((>= i end) idx)
    332        (let* ((code (char-code (schar string i))))
     370       (let* ((char (schar string i))
     371              (code (char-code char)))
    333372         (declare (type (mod #x110000) code))
    334373         (if (>= code 128)
    335            (setq code (char-code #\Sub)))
     374           (setq code (note-encoding-problem char pointer :us-ascii (char-code #\Sub))))
    336375         (setf (%get-unsigned-byte pointer idx) code)
    337376         (incf idx)))))
     
    346385         (declare (type (unsigned-byte 8) code))
    347386         (if (>= code 128)
    348            (setf (schar string i) #\sub)
     387           (setf (schar string i) (note-vector-decoding-problem pointer index :us-ascii))
    349388           (setf (schar string i) (code-char code)))))))
    350389  :octets-in-string-function
     
    448487                     
    449488       (declare (type (mod #x110000) code))
    450        (funcall write-function stream (or c2 (char-code #\Sub)))
     489       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-2 (char-code #\Sub))))
    451490       1)))
    452491  :stream-decode-function
     
    467506     (do* ((i start (1+ i)))
    468507          ((>= i end) idx)
    469        (let* ((code (char-code (schar string i)))
     508       (let* ((char (schar string i))
     509              (code (char-code char))
    470510              (c2 (cond ((< code #xa0) code)
    471511                          ((< code #x180)
     
    476516                                  (the fixnum (- code #x2c0)))))))
    477517         (declare (type (mod #x110000) code))
    478          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     518         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-2 (char-code #\Sub))))
    479519         (incf idx)))))
    480520  :vector-decode-function
     
    498538     (do* ((i start (1+ i)))
    499539          ((>= i end) idx)
    500        (let* ((code (char-code (schar string i)))
     540       (let* ((char (schar string i))
     541              (code (char-code char))
    501542              (c2 (cond ((< code #xa0) code)
    502543                        ((< code #x180)
     
    507548                                (the fixnum (- code #x2c0)))))))
    508549       (declare (type (mod #x110000) code))
    509        (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     550       (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-2 (char-code #\Sub))))
    510551       (1+ idx)))))
    511552  :memory-decode-function
     
    619660                              (the fixnum (- code #x2d8)))))))
    620661       (declare (type (mod #x110000) code))
    621        (funcall write-function stream (or c2 (char-code #\Sub)))
     662       (funcall write-function stream (or c2
     663                                          (note-encoding-problem
     664                                           char stream :iso-8859-3 (char-code #\Sub))))
    622665       1)))
    623666  :stream-decode-function
     
    652695               (the fixnum (- code #x2d8)))))))
    653696         (declare (type (mod #x110000) code))
    654          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     697         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-3 (char-code #\Sub))))
    655698         (incf idx)))))
    656699  :vector-decode-function
     
    674717     (do* ((i start (1+ i)))
    675718          ((>= i end) idx)
    676        (let* ((code (char-code (schar string i)))
     719       (let* ((char (schar string i))
     720              (code (char-code char))
    677721              (c2 (cond ((< code #xa0) code)
    678722                        ((< code #x100)
     
    686730                                (the fixnum (- code #x2d8)))))))
    687731         (declare (type (mod #x110000) code))
    688          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     732         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-3 (char-code #\Sub))))
    689733         (incf idx)))))
    690734  :memory-decode-function
     
    798842                     
    799843       (declare (type (mod #x110000) code))
    800        (funcall write-function stream (or c2 (char-code #\Sub)))
     844       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-4 (char-code #\Sub))))
    801845       1)))
    802846  :stream-decode-function
     
    827871                                (the fixnum (- code #x2c0)))))))
    828872         (declare (type (mod #x110000) code))
    829          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     873         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-4 (char-code #\Sub))))
    830874         (incf idx)))))
    831875  :vector-decode-function
     
    849893     (do* ((i start (1+ i)))
    850894          ((>= i end) idx)
    851        (let* ((code (char-code (schar string i)))
     895       (let* ((char (schar string i))
     896              (code (char-code char))
    852897              (c2 (cond ((< code #xa0) code)
    853898                        ((< code #x180)
     
    858903                                (the fixnum (- code #x2c0)))))))
    859904         (declare (type (mod #x110000) code))
    860          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     905         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-4 (char-code #\Sub))))
    861906         (incf idx)))))
    862907  :memory-decode-function
     
    950995                     
    951996       (declare (type (mod #x110000) code))
    952        (funcall write-function stream (or c2 (char-code #\Sub)))
     997       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-5 (char-code #\Sub))))
    953998       1)))
    954999  :stream-decode-function
     
    9791024                                (the fixnum (- code #x400)))))))
    9801025         (declare (type (mod #x110000) code))
    981          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1026         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-5 (char-code #\Sub))))
    9821027         (incf idx)))))
    9831028  :vector-decode-function
     
    10011046     (do* ((i start (1+ i)))
    10021047          ((>= i end) idx)
    1003        (let* ((code (char-code (schar string i)))
     1048       (let* ((char (schar string i))
     1049              (code (char-code char))
    10041050              (c2 (cond ((< code #xa0) code)
    10051051                        ((< code #xb0)
     
    10101056                                (the fixnum (- code #x400)))))))
    10111057         (declare (type (mod #x110000) code))
    1012          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1058         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-5 (char-code #\Sub))))
    10131059         (incf idx)))))
    10141060  :memory-decode-function
     
    10991145                     
    11001146       (declare (type (mod #x110000) code))
    1101        (funcall write-function stream (or c2 (char-code #\Sub)))
     1147       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-6 (char-code #\Sub))))
    11021148       1)))
    11031149  :stream-decode-function
     
    11281174                                (the fixnum (- code #x608)))))))
    11291175         (declare (type (mod #x110000) code))
    1130          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1176         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-6 (char-code #\Sub))))
    11311177         (incf idx)))))
    11321178  :vector-decode-function
     
    11501196     (do* ((i start (1+ i)))
    11511197          ((>= i end) idx)
    1152        (let* ((code (char-code (schar string i)))
     1198       (let* ((char (schar string i))
     1199              (code (char-code char))
    11531200              (c2 (cond ((< code #xa0) code)
    11541201                        ((< code #xb0)
     
    11591206                                (the fixnum (- code #x608)))))))
    11601207         (declare (type (mod #x110000) code))
    1161          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1208         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-6 (char-code #\Sub))))
    11621209         (incf idx)))))
    11631210  :memory-decode-function
     
    12671314             
    12681315       (declare (type (mod #x110000) code))
    1269        (funcall write-function stream (or c2 (char-code #\Sub)))
     1316       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-7 (char-code #\Sub))))
    12701317       1)))
    12711318  :stream-decode-function
     
    13021349                              (the fixnum (- code #x20ac)))))))
    13031350         (declare (type (mod #x110000) code))
    1304          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1351         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-7 (char-code #\Sub))))
    13051352         (incf idx)))))
    13061353  :vector-decode-function
     
    13241371     (do* ((i start (1+ i)))
    13251372          ((>= i end) idx)
    1326        (let* ((code (char-code (schar string i)))
     1373       (let* ((char (schar string i))
     1374              (code (char-code char))
    13271375              (c2 (cond ((< code #xa0) code)
    13281376                      ((< code #xc0)
     
    13391387                              (the fixnum (- code #x20ac)))))))
    13401388         (declare (type (mod #x110000) code))
    1341          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1389         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-7 (char-code #\Sub))))
    13421390         (incf idx)))))
    13431391  :memory-decode-function
     
    14391487             
    14401488       (declare (type (mod #x110000) code))
    1441        (funcall write-function stream (or c2 (char-code #\Sub)))
     1489       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-8 (char-code #\Sub))))
    14421490       1)))
    14431491  :stream-decode-function
     
    14711519                              (the fixnum (- code #x2008)))))))
    14721520         (declare (type (mod #x110000) code))
    1473          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1521         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-8 (char-code #\Sub))))
    14741522         (incf idx)))))
    14751523  :vector-decode-function
     
    14931541     (do* ((i start (1+ i)))
    14941542          ((>= i end) idx)
    1495        (let* ((code (char-code (schar string i)))
     1543       (let* ((char (schar string i))
     1544              (code (char-code char))
    14961545              (c2 (cond ((< code #xa0) code)
    14971546                      ((< code #xf8)
     
    15051554                              (the fixnum (- code #x2008)))))))
    15061555         (declare (type (mod #x110000) code))
    1507          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1556         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-8 (char-code #\Sub))))
    15081557         (incf idx)))))
    15091558  :memory-decode-function
     
    15881637             
    15891638       (declare (type (mod #x110000) code))
    1590        (funcall write-function stream (or c2 (char-code #\Sub)))
     1639       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-9 (char-code #\Sub))))
    15911640       1)))
    15921641  :stream-decode-function
     
    16171666                              (the fixnum (- code #x118)))))))
    16181667         (declare (type (mod #x110000) code))
    1619          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1668         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-9 (char-code #\Sub))))
    16201669         (incf idx)))))
    16211670  :vector-decode-function
     
    16391688     (do* ((i start (1+ i)))
    16401689          ((>= i end) idx)
    1641        (let* ((code (char-code (schar string i)))
     1690       (let* ((char (schar string i))
     1691              (code (char-code char))
    16421692              (c2 (cond ((< code #xd0) code)
    16431693                      ((< code #x100)
     
    16481698                              (the fixnum (- code #x118)))))))
    16491699         (declare (type (mod #x110000) code))
    1650          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1700         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-9 (char-code #\Sub))))
    16511701         (incf idx)))))
    16521702  :memory-decode-function
     
    17441794                              (the fixnum (- code #xa0)))))))
    17451795       (declare (type (mod #x110000) code))
    1746        (funcall write-function stream (or c2 (char-code #\Sub)))
     1796       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-10 (char-code #\Sub))))
    17471797       1)))
    17481798  :stream-decode-function
     
    17701820                              (the fixnum (- code #xa0)))))))
    17711821         (declare (type (mod #x110000) code))
    1772          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1822         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-10 (char-code #\Sub))))
    17731823         (incf idx)))))
    17741824  :vector-decode-function
     
    17921842     (do* ((i start (1+ i)))
    17931843          ((>= i end) idx)
    1794        (let* ((code (char-code (schar string i)))
     1844       (let* ((char (schar string i))
     1845              (code (char-code char))
    17951846              (c2 (cond ((< code #xa0) code)
    17961847                      ((< code #x180)
     
    17981849                              (the fixnum (- code #xa0)))))))
    17991850         (declare (type (mod #x110000) code))
    1800          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1851         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-10 (char-code #\Sub))))
    18011852         (incf idx)))))
    18021853  :memory-decode-function
     
    18391890                       (+ code #x0d60)))))
    18401891       (declare (type (mod #x110000) code))
    1841        (funcall write-function stream (or c2 (char-code #\Sub)))
     1892       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-11 (char-code #\Sub))))
    18421893       1)))
    18431894  :stream-decode-function
     
    18451896   iso-8859-11-stream-decode
    18461897   (lambda (1st-unit next-unit-function stream)
    1847      (declare (ignore next-unit-function stream)
     1898     (declare (ignore next-unit-function)
    18481899              (type (unsigned-byte 8) 1st-unit))
    18491900     (if (< 1st-unit #xa1)
     
    18541905                          (<= 1st-unit #xe3e))))
    18551906         (code-char (- 1st-unit #xd60))
    1856          #\Replacement_Character))))
     1907         (note-stream-decoding-problem stream)))))
    18571908  :vector-encode-function
    18581909  (nfunction
     
    18701921                       (+ code #x0d60)))))
    18711922         (declare (type (mod #x110000) code))
    1872          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     1923         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-11 (char-code #\Sub))))
    18731924         (incf idx)))))
    18741925  :vector-decode-function
     
    18901941                                    (<= 1st-unit #xe3e))))
    18911942                   (code-char (- 1st-unit #xd60))
    1892                    #\Replacement_Character)))))))
     1943                   (note-vector-decoding-problem vector index :iso-8859-11))))))))
    18931944  :memory-encode-function
    18941945  (nfunction
     
    18971948     (do* ((i start (1+ i)))
    18981949          ((>= i end) idx)
    1899        (let* ((code (char-code (schar string i)))
     1950       (let* ((char (schar string i))
     1951              (code (char-code char))
    19001952              (c2 (cond ((< code #xa1) code)
    19011953                      ((and (<= code #xfb)
     
    19031955                       (+ code #x0d60)))))
    19041956         (declare (type (mod #x110000) code))
    1905          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     1957         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-11 (char-code #\Sub))))
    19061958         (incf idx)))))
    19071959  :memory-decode-function
     
    19221974                                    (<= 1st-unit #xe3e))))
    19231975                   (code-char (- 1st-unit #xd60))
    1924                    #\Replacement_Character)))))))
     1976                   (note-vector-decoding-problem pointer index :iso-8859-11))))))))
    19251977  :octets-in-string-function
    19261978  #'8-bit-fixed-width-octets-in-string
     
    20162068                              (the fixnum (- code #x2018)))))))
    20172069       (declare (type (mod #x110000) code))
    2018        (funcall write-function stream (or c2 (char-code #\Sub)))
     2070       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-13 (char-code #\Sub))))
    20192071       1)))
    20202072  :stream-decode-function
     
    20462098                              (the fixnum (- code #x2018)))))))
    20472099         (declare (type (mod #x110000) code))
    2048          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     2100         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-13 (char-code #\Sub))))
    20492101         (incf idx)))))
    20502102  :vector-decode-function
     
    20682120     (do* ((i start (1+ i)))
    20692121          ((>= i end) idx)
    2070        (let* ((code (char-code (schar string i)))
     2122       (let* ((char (schar string i))
     2123              (code (char-code char))
    20712124              (c2 (cond ((< code #xa0) code)
    20722125                      ((< code #x180)
     
    20782131                              (the fixnum (- code #x2018)))))))
    20792132         (declare (type (mod #x110000) code))
    2080          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     2133         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-13 (char-code #\Sub))))
    20812134         (incf idx)))))
    20822135  :memory-decode-function
     
    22092262                              (the fixnum (- code #x1ef0)))))))
    22102263       (declare (type (mod #x110000) code))
    2211        (funcall write-function stream (or c2 (char-code #\Sub)))
     2264       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-14 (char-code #\Sub))))
    22122265       1)))
    22132266  :stream-decode-function
     
    22472300                              (the fixnum (- code #x1ef0)))))))
    22482301         (declare (type (mod #x110000) code))
    2249          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     2302         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-14 (char-code #\Sub))))
    22502303         (incf idx)))))
    22512304  :vector-decode-function
     
    22692322     (do* ((i start (1+ i)))
    22702323          ((>= i end) idx)
    2271        (let* ((code (char-code (schar string i)))
     2324       (let* ((char (schar string i))
     2325              (code (char-code char))
    22722326              (c2 (cond ((< code #xa0) code)
    22732327                      ((< code #x100)
     
    22872341                              (the fixnum (- code #x1ef0)))))))
    22882342         (declare (type (mod #x110000) code))
    2289          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     2343         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-14 (char-code #\Sub))))
    22902344         (incf idx)))))
    22912345  :memory-decode-function
     
    23852439                      ((= code #x20ac) #xa4))))
    23862440       (declare (type (mod #x110000) code))
    2387        (funcall write-function stream (or c2 (char-code #\Sub)))
     2441       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-15 (char-code #\Sub))))
    23882442       1)))
    23892443  :stream-decode-function
     
    24152469                      ((= code #x20ac) #xa4))))
    24162470         (declare (type (mod #x110000) code))
    2417          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     2471         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-15 (char-code #\Sub))))
    24182472         (incf idx)))))
    24192473  :vector-decode-function
     
    24372491     (do* ((i start (1+ i)))
    24382492          ((>= i end) idx)
    2439        (let* ((code (char-code (schar string i)))
     2493       (let* ((char (schar string i))
     2494              (code (char-code char))
    24402495              (c2 (cond ((< code #xa0) code)
    24412496                      ((< code #x100)
     
    24472502                      ((= code #x20ac) #xa4))))
    24482503         (declare (type (mod #x110000) code))
    2449          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     2504         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-15 (char-code #\Sub))))
    24502505         (incf idx)))))
    24512506  :memory-decode-function
     
    25602615                      ((= code #x20ac) #xa4))))
    25612616       (declare (type (mod #x110000) code))
    2562        (funcall write-function stream (or c2 (char-code #\Sub)))
     2617       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-16 (char-code #\Sub))))
    25632618       1)))
    25642619  :stream-decode-function
     
    25932648                      ((= code #x20ac) #xa4))))
    25942649         (declare (type (mod #x110000) code))
    2595          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     2650         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-16 (char-code #\Sub))))
    25962651         (incf idx)))))
    25972652  :vector-decode-function
     
    26152670     (do* ((i start (1+ i)))
    26162671          ((>= i end) idx)
    2617        (let* ((code (char-code (schar string i)))
     2672       (let* ((char (schar string i))
     2673              (code (char-code char))
    26182674              (c2 (cond ((< code #xa0) code)
    26192675                      ((< code #x180)
     
    26282684                      ((= code #x20ac) #xa4))))
    26292685         (declare (type (mod #x110000) code))
    2630          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     2686         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-16 (char-code #\Sub))))
    26312687         (incf idx)))))
    26322688  :memory-decode-function
     
    27992855                      ((= code #xf8ff) #xf0))))
    28002856       (declare (type (mod #x110000) code))
    2801        (funcall write-function stream (or c2 (char-code #\Sub)))
     2857       (funcall write-function stream (or c2 (note-encoding-problem char stream :macintosh (char-code #\Sub))))
    28022858       1)))
    28032859  :stream-decode-function
     
    28462902                      ((= code #xf8ff) #xf0))))
    28472903         (declare (type (mod #x110000) code))
    2848          (setf (aref vector idx) (or c2 (char-code #\Sub)))
     2904         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :macintosh (char-code #\Sub))))
    28492905         (incf idx)))))
    28502906  :vector-decode-function
     
    28682924     (do* ((i start (1+ i)))
    28692925          ((>= i end) idx)
    2870        (let* ((code (char-code (schar string i)))
    2871             (c2 (cond ((< code #x80) code)
     2926       (let* ((char (schar string i))
     2927              (code (char-code char))
     2928              (c2 (cond ((< code #x80) code)
    28722929                      ((and (>= code #xa0) (< code #x100)
    28732930                       (svref *unicode-a0-100-to-macintosh*
     
    28952952                      ((= code #xf8ff) #xf0))))
    28962953         (declare (type (mod #x110000) code))
    2897          (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub)))
     2954         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :macintosh (char-code #\Sub))))
    28982955         (incf idx)))))
    28992956  :memory-decode-function
     
    29843041                       (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
    29853042                       (the fixnum (logxor s1 #x80))))
    2986                      #\Replacement_Character)
     3043                     (note-stream-decoding-problem stream))
    29873044                   (let* ((s2 (funcall next-unit-function stream)))
    29883045                     (if (eq s2 :eof)
     
    30053062                                                            6))
    30063063                                                     (the fixnum (logand s2 #x3f)))))))
    3007                                  #\Replacement_Character)
    3008                              #\Replacement_Character)
     3064                                 (note-stream-decoding-problem stream))
     3065                             (note-stream-decoding-problem stream))
    30093066                           (if (< 1st-unit #xf8)
    30103067                             (let* ((s3 (funcall next-unit-function stream)))
     
    30313088                                            (ash (the fixnum (logxor s2 #x80)) 6))
    30323089                                          (the fixnum (logxor s3 #x80))))))
    3033                                      #\Replacement_Character))))
    3034                              #\Replacement_Character)))))))))
    3035            #\Replacement_Character))))
     3090
     3091
     3092                                     (note-stream-decoding-problem stream)))))
     3093                             (note-stream-decoding-problem stream))))))))))
     3094           (note-stream-decoding-problem stream)))))
    30363095    :vector-encode-function
    30373096    (nfunction
     
    31343193                                              (ash (the fixnum (logxor 3rd-unit #x80)) 6))
    31353194                                            (the fixnum (logxor 4th-unit #x80))))))))))))))))
    3136                (setf (schar string i) (or char #\Replacement_Character)))))))
     3195               (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-8))))))))
    31373196    :memory-encode-function
    31383197    #'utf-8-memory-encode
     
    32253284                     (< 2nd-unit #xe000))
    32263285              (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)
    3227               #\Replacement_Character))))
    3228       #\Replacement_Character)))
     3286              (note-stream-decoding-problem stream)))))
     3287      (note-stream-decoding-problem stream))))
    32293288
    32303289
     
    33593418                                  (< 2nd-unit #xe000))
    33603419                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3361              (setf (schar string i) (or char #\Replacement_Character)))))))
     3420             (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
    33623421    :memory-encode-function
    33633422    (nfunction
     
    34033462                                    (< 2nd-unit #xe000))
    34043463                             (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3405             (setf (schar string i) (or char #\Replacement_Character)))))))
     3464            (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
    34063465    :octets-in-string-function
    34073466    #'utf-16-octets-in-string
     
    35243583                                (< 2nd-unit #xe000))
    35253584                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3526            (setf (schar string i) (or char #\Replacement_Character)))))))
     3585           (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
    35273586  :memory-encode-function
    35283587  (nfunction
     
    35683627                                (< 2nd-unit #xe000))
    35693628                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3570            (setf (schar string i) (or char #\Replacement_Character)))))))
     3629           (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
    35713630  :octets-in-string-function
    35723631  #'utf-16-octets-in-string
     
    37093768                                  (< 2nd-unit #xe000))
    37103769                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3711              (setf (schar string i) (or char #\Replacement_Character))))))))
     3770             (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-16)))))))))
    37123771  :memory-encode-function
    37133772  (nfunction
     
    37693828                                  (< 2nd-unit #xe000))
    37703829                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
    3771              (setf (schar string i) (or char #\Replacement_Character))))))))
     3830             (setf (schar string i) (or char (note-vector-decoding-problem pointer index :utf-16)))))))))
    37723831  :octets-in-string-function
    37733832  (nfunction
     
    38603919    (declare (type (mod #x110000) code))
    38613920    (if (>= code #x10000)
    3862       (setq code (char-code #\Replacement_Character)))
     3921      (setq code (note-encoding-problem char stream :ucs-2 (char-code #\Replacement_Character))))
    38633922    (funcall write-function stream code)
    38643923    1))
     
    38663925(defun ucs-2-stream-decode (1st-unit next-unit-function stream)
    38673926  (declare (type (unsigned-byte 16) 1st-unit)
    3868            (ignore next-unit-function stream))
     3927           (ignore next-unit-function))
    38693928  ;; CODE-CHAR returns NIL on either half of a surrogate pair.
    38703929  (or (code-char 1st-unit)
    3871       #\Replacement_Character))
     3930      (note-stream-decoding-problem stream)))
    38723931
    38733932
     
    39223981         (declare (type (mod #x110000) code))
    39233982         (when (>= code #x10000)
    3924            (setq code (char-code #\Replacement_Character)))
     3983           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))))
    39253984         (setf (%native-u8-ref-u16 vector idx) code)
    39263985         (incf idx 2)))))
     
    39383997       (setf (schar string i)
    39393998             (or (code-char (%native-u8-ref-u16 vector index))
    3940                  #\Replacement_Character)))))
     3999                 (note-vector-decoding-problem vector index  #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le))))))
    39414000  :memory-encode-function
    39424001  (nfunction
     
    39464005     (do* ((i start (1+ i)))
    39474006          ((>= i end) idx)
    3948        (let* ((code (char-code (schar string i))))
     4007       (let* ((char (schar string i))
     4008              (code (char-code char)))
    39494009         (declare (type (mod #x110000) code))
    39504010         (setf (%get-unsigned-word pointer idx)
    39514011                      (if (>= code #x10000)
    3952                         (char-code #\Replacement_Character)
     4012                        (note-encoding-problem char pointer #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))
    39534013                        code))
    39544014         (incf idx 2)))))
     
    39644024       (let* ((1st-unit (%get-unsigned-word pointer index)))
    39654025         (declare (type (unsigned-byte 16) 1st-unit))
    3966          (setf (schar string i) (or (char-code 1st-unit) #\Replacement_Character))))))
     4026         (setf (schar string i) (or (char-code 1st-unit) (note-vector-decoding-problem pointer index  #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le)))))))
    39674027  :octets-in-string-function
    39684028  #'ucs-2-octets-in-string
     
    40114071         (declare (type (mod #x110000) code))
    40124072         (when (>= code #x10000)
    4013            (setq code (char-code #\Replacement_Character)))
     4073           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character))))
    40144074         (setf (%reversed-u8-ref-u16 vector idx) code)
    40154075         (incf idx 2)))))
     
    40274087       (setf (schar string i)
    40284088             (or (code-char (%reversed-u8-ref-u16 vector index))
    4029                  #\Replacement_Character)))))
     4089                 (note-vector-decoding-problem vector index #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be))))))
    40304090  :memory-encode-function
    40314091  (nfunction
     
    40354095     (do* ((i start (1+ i)))
    40364096          ((>= i end) idx)
    4037        (let* ((code (char-code (schar string i))))
     4097       (let* ((char (schar string i))
     4098              (code (char-code char)))
    40384099         (declare (type (mod #x110000) code))
    40394100         (setf (%get-unsigned-word pointer idx)
    40404101               (if (>= code #x10000)
    4041                  (%swap-u16 (char-code #\Replacement_Character))
     4102                 (%swap-u16 (note-encoding-problem char pointer #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character)))
    40424103                 (%swap-u16 code)))
    40434104         (incf idx 2)))))
     
    40534114       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
    40544115         (declare (type (unsigned-byte 16) 1st-unit))
    4055          (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character))))))
     4116         (setf (schar string i) (or (code-char 1st-unit) (note-vector-decoding-problem pointer index #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be)))))))
    40564117  :octets-in-string-function
    40574118  #'ucs-2-octets-in-string
     
    40944155         (declare (type (mod #x110000) code))
    40954156         (when (>= code #x10000)
    4096            (setq code (char-code #\Replacement_Character)))
     4157           (setq code (note-encoding-problem char vector :ucs-2 (char-code #\Replacement_Character))))
    40974158         (setf (%native-u8-ref-u16 vector idx) code)
    40984159         (incf idx 2)))))
     
    41214182                            (%native-u8-ref-u16 vector index))))
    41224183             (declare (type (unsigned-byte 16) 1st-unit))
    4123              (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))))
     4184             (setf (schar string i) (or (code-char 1st-unit)
     4185                                        (note-vector-decoding-problem vector index :ucs-2))))))))
    41244186  :memory-encode-function
    41254187  (nfunction
     
    41314193     (do* ((i start (1+ i)))
    41324194          ((>= i end) idx)
    4133        (let* ((code (char-code (schar string i))))
     4195       (let* ((char (schar string i))
     4196              (code (char-code char)))
    41344197         (declare (type (mod #x110000) code))
    41354198         (setf (%get-unsigned-word pointer idx)
    41364199                      (if (>= code #x10000)
    4137                         (char-code #\Replacement_Character)
     4200                        (note-encoding-problem char pointer :ucs-2 (char-code #\Replacement_Character))
    41384201                        code))
    41394202         (incf idx 2)))))
     
    41614224         (declare (type (unsigned-byte 16) 1st-unit))
    41624225         (if swap (setq 1st-unit (%swap-u16 1st-unit)))
    4163          (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))))
     4226         (setf (schar string i) (or (code-char 1st-unit)
     4227                                    (note-vector-decoding-problem pointer index :ucs-2))))))))
    41644228  :octets-in-string-function
    41654229  (nfunction
     
    43424406               (or (if (< code char-code-limit)
    43434407                      (code-char code))
    4344                    #\Replacement_Character))))))
     4408                   (note-vector-decoding-problem vector index #+big-endian-target :utf-32be #-big-endian-target :utf-32le)))))))
    43454409  :memory-encode-function
    43464410  (nfunction
     
    43674431         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
    43684432                                      (code-char 1st-unit))
    4369                                     #\Replacement_Character))))))
     4433                                    (note-vector-decoding-problem
     4434                                     pointer index #+big-endian-target :utf-32be #-big-endian-target :utf-32le)))))))
    43704435  :octets-in-string-function
    43714436  #'ucs-4-octets-in-string
     
    44404505               (or (if (< code char-code-limit)
    44414506                     (code-char code))
    4442                    #\Replacement_Character))))))
     4507                   (note-vector-decoding-problem vector index #+big-endian-target :utf-32le #-big-endian-target :utf-32be)))))))
    44434508  :memory-encode-function
    44444509  (nfunction
     
    44654530         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
    44664531                                      (code-char 1st-unit))
    4467                                     #\Replacement_Character))))))
     4532                                    (note-vector-decoding-problem pointer index #+big-endian-target :utf-32le #-big-endian-target :utf-32be)))))))
    44684533
    44694534  :octets-in-string-function
     
    45484613             (setf (schar string i) (or (if (< 1st-unit char-code-limit)
    45494614                                          (code-char 1st-unit))
    4550                                         #\Replacement_Character)))))))
     4615                                        (note-vector-decoding-problem
     4616                                         vector index :utf-32))))))))
    45514617  :memory-encode-function
    45524618  (nfunction
     
    45874653         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
    45884654                                      (code-char 1st-unit))
    4589                                     #\Replacement_Character)))))))
     4655                                    (note-vector-decoding-problem
     4656                                     pointer index :utf-32))))))))
    45904657  :octets-in-string-function
    45914658  (nfunction
  • trunk/source/lib/ccl-export-syms.lisp

    r15146 r15236  
    343343     event-dispatch
    344344     *ticks-per-second*
     345     encoding-problem
     346     decoding-problem
     347     with-encoding-problems-as-errors
     348     with-decoding-problems-as-errors
    345349
    346350     *application*
  • trunk/source/lib/macros.lisp

    r15223 r15236  
    17691769            (setf (%get-unsigned-word ,sym ,noctets) 0)
    17701770            ,@body))))))
     1771
     1772(defmacro with-encoding-problems-as-errors (&body body)
     1773  `(handler-bind ((encoding-problem #'error))
     1774    ,@body))
     1775
     1776(defmacro with-decoding-problems-as-errors (&body body)
     1777  `(handler-bind ((decoding-problem #'error))
     1778    ,@body))
    17711779
    17721780(defmacro with-pointers (speclist &body body)
Note: See TracChangeset for help on using the changeset viewer.