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

Diff of /src/code/extfmts.lisp

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

revision 1.35 by rtoy, Mon Jul 12 13:58:42 2010 UTC revision 1.35.4.3 by rtoy, Sun Aug 15 15:07:51 2010 UTC
# Line 649  character and illegal outputs are replac Line 649  character and illegal outputs are replac
649    (code-to-octets (code state output error)    (code-to-octets (code state output error)
650      `(,output (if (> ,code 255)      `(,output (if (> ,code 255)
651                    (if ,error                    (if ,error
652                        (funcall ,error                        (locally
653                                 (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream")                            ;; No warnings about fdefinition
654                                 ,code 1)                            (declare (optimize (ext:inhibit-warnings 3)))
655                            (funcall ,error
656                                     (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream")
657                                     ,code 1))
658                        #x3F)                        #x3F)
659                    ,code))))                    ,code))))
660    
# Line 753  character and illegal outputs are replac Line 756  character and illegal outputs are replac
756                      ;; illegal.  So are codepoints that are too large.                      ;; illegal.  So are codepoints that are too large.
757                      (if ,error                      (if ,error
758                          (if (lisp::surrogatep code)                          (if (lisp::surrogatep code)
759                              (funcall ,error                              (locally
760                                       (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A")                                  (declare (optimize (ext:inhibit-warnings 3)))
761                                                ,external-format)                                (funcall ,error
762                                       code nil)                                         (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A")
763                              (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil))                                                 ,external-format)
764                                           code nil))
765                                (locally
766                                    (declare (optimize (ext:inhibit-warnings 3)))
767                                  (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil)))
768                          #-(and unicode (not unicode-bootstrap)) #\?                          #-(and unicode (not unicode-bootstrap)) #\?
769                          #+(and unicode (not unicode-bootstrap)) #\U+FFFD))                          #+(and unicode (not unicode-bootstrap)) #\U+FFFD))
770                     #+unicode                     #+unicode
# Line 788  character and illegal outputs are replac Line 795  character and illegal outputs are replac
795                       (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)                       (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
796                                   (surrogates-to-codepoint (car ,nstate) ,nchar)                                   (surrogates-to-codepoint (car ,nstate) ,nchar)
797                                   (if ,error                                   (if ,error
798                                       (funcall ,error                                       (locally
799                                                (intl:gettext "Cannot convert invalid surrogate #x~X to character")                                           (declare (optimize (ext:inhibit-warnings 3)))
800                                                ,nchar)                                         (funcall ,error
801                                                    (intl:gettext "Cannot convert invalid surrogate #x~X to character")
802                                                    ,nchar))
803                                       +replacement-character-code+)))                                       +replacement-character-code+)))
804                     (setf (car ,nstate) nil))                     (setf (car ,nstate) nil))
805                   ;; A lone trailing (low) surrogate gets replaced with                   ;; A lone trailing (low) surrogate gets replaced with
806                   ;; the replacement character.                   ;; the replacement character.
807                   (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)                   (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
808                               (if ,error                               (if ,error
809                                   (funcall ,error                                   (locally
810                                            (intl:gettext "Cannot convert lone trailing surrogate #x~X to character")                                       (declare (optimize (ext:inhibit-warnings 3)))
811                                            ,nchar)                                     (funcall ,error
812                                                (intl:gettext "Cannot convert lone trailing surrogate #x~X to character")
813                                                ,nchar))
814                                   +replacement-character-code+)                                   +replacement-character-code+)
815                               (char-code ,nchar)))))))))                               (char-code ,nchar)))))))))
816    
# Line 907  character and illegal outputs are replac Line 918  character and illegal outputs are replac
918                   (or string (make-string (length octets)))                   (or string (make-string (length octets)))
919                   s-start s-end                   s-start s-end
920                   error)                   error)
921          (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))
922    
923    
924    (def-ef-macro ef-octets-to-string-counted (extfmt lisp::lisp +ef-max+ +ef-os+)
925      `(lambda (octets ptr end state ocount string s-start s-end error
926                &aux (pos s-start) (last-octet 0))
927         (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
928                  (type (simple-array (unsigned-byte 8) (*)) octets ocount)
929                  (type kernel:index pos end last-octet s-start s-end)
930                  (type (integer -1 (#.array-dimension-limit)) ptr)
931                  (type simple-string string)
932                  (ignorable state))
933         (catch 'end-of-octets
934           (loop for k of-type fixnum from 0
935              while (< pos s-end)
936              do (setf (schar string pos)
937                       (octets-to-char ,extfmt state (aref ocount k)
938                                       (if (>= ptr end)
939                                           (throw 'end-of-octets nil)
940                                           (aref octets (incf ptr)))
941                                       (lambda (n) (decf ptr n))
942                                       error))
943              (incf pos)
944              (incf last-octet (aref ocount k))))
945         (values string pos last-octet state)))
946    
947    ;; Like OCTETS-TO-STRING, but we take an extra argument which is an
948    ;; array which will contain the number of octets read for each
949    ;; character placed in the output string.
950    (defun octets-to-string-counted (octets ocount
951                                     &key (start 0) end (external-format :default)
952                                     (string nil stringp)
953                                     (s-start 0) (s-end nil s-end-p)
954                                     (state nil)
955                                     error)
956      "Octets-to-string converts an array of octets in Octets to a string
957      according to the specified External-format.  The array of octets is
958      bounded by Start (defaulting ot 0) and End (defaulting to the end of
959      the array.  If String is not given, a new string is created.  If
960      String is given, the converted octets are stored in String, starting
961      at S-Start (defaulting to the 0) and ending at S-End (defaulting to
962      the length of String).  If the string is not large enough to hold
963      all of characters, then some octets will not be converted.  A State
964      may also be specified; this is used as the state of the external
965      format.
966    
967      In Ocount, the number of octets read for each character in the
968      string is saved
969    
970      Four values are returned: the string, the number of characters read,
971      the number of octets actually consumed and the new state of the
972      external format."
973      (declare (type (simple-array (unsigned-byte 8) (*)) octets ocount)
974               (type kernel:index start s-start)
975               (type (or kernel:index null) end)
976               (type (or simple-string null) string))
977      (let ((s-end (if s-end-p
978                       s-end
979                       (if stringp
980                           (length string)
981                           (length octets)))))
982        (multiple-value-bind (string pos last-octet new-state)
983            (funcall (ef-octets-to-string-counted external-format)
984                     octets (1- start) (1- (or end (length octets)))
985                     state
986                     ocount
987                     (or string (make-string (length octets)))
988                     s-start s-end
989                     error)
990        (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))        (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))
991    
992    

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.35.4.3

  ViewVC Help
Powered by ViewVC 1.1.5