/[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.5 by rtoy, Mon Sep 6 01:01:27 2010 UTC
# Line 35  Line 35 
35    "Hash table mapping an external format alias to the actual external    "Hash table mapping an external format alias to the actual external
36    format implementation")    format implementation")
37    
38    ;; Each time DEF-EF-MACRO is used to define a new external format
39    ;; macro, a unique value must be used for the index.  The mapping
40    ;; between the macro and the index is here.
41  (vm::defenum (:prefix "+EF-" :suffix "+" :start 1)  (vm::defenum (:prefix "+EF-" :suffix "+" :start 1)
42    str                                   ; string length    str                                   ; string length
43    cin                                   ; input a character    cin                                   ; input a character
# Line 47  Line 50 
50    de                                    ; decode    de                                    ; decode
51    flush                                 ; flush state    flush                                 ; flush state
52    copy-state                            ; copy state    copy-state                            ; copy state
53      osc                                   ; octets to string, counted
54    max)    max)
55    
56  ;; Unicode replacement character U+FFFD  ;; Unicode replacement character U+FFFD
# Line 649  character and illegal outputs are replac Line 653  character and illegal outputs are replac
653    (code-to-octets (code state output error)    (code-to-octets (code state output error)
654      `(,output (if (> ,code 255)      `(,output (if (> ,code 255)
655                    (if ,error                    (if ,error
656                        (funcall ,error                        (locally
657                                 (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream")                            ;; No warnings about fdefinition
658                                 ,code 1)                            (declare (optimize (ext:inhibit-warnings 3)))
659                            (funcall ,error
660                                     (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream")
661                                     ,code 1))
662                        #x3F)                        #x3F)
663                    ,code))))                    ,code))))
664    
# Line 682  character and illegal outputs are replac Line 689  character and illegal outputs are replac
689  (defun ensure-cache (ef id reqd)  (defun ensure-cache (ef id reqd)
690    (let ((base (or (getf *ef-extensions* id)    (let ((base (or (getf *ef-extensions* id)
691                    (setf (getf *ef-extensions* id)                    (setf (getf *ef-extensions* id)
692                        (prog1 *ef-base* (incf *ef-base* reqd))))))                          (prog1 *ef-base* (incf *ef-base* reqd))))))
693      (when (< (length (ef-cache ef)) (+ base reqd))      (when (< (length (ef-cache ef)) (+ base reqd))
694        (setf (efx-cache (ef-efx ef))        (setf (efx-cache (ef-efx ef))
695            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
# Line 753  character and illegal outputs are replac Line 760  character and illegal outputs are replac
760                      ;; illegal.  So are codepoints that are too large.                      ;; illegal.  So are codepoints that are too large.
761                      (if ,error                      (if ,error
762                          (if (lisp::surrogatep code)                          (if (lisp::surrogatep code)
763                              (funcall ,error                              (locally
764                                       (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A")                                  (declare (optimize (ext:inhibit-warnings 3)))
765                                                ,external-format)                                (funcall ,error
766                                       code nil)                                         (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A")
767                              (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil))                                                 ,external-format)
768                                           code nil))
769                                (locally
770                                    (declare (optimize (ext:inhibit-warnings 3)))
771                                  (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil)))
772                          #-(and unicode (not unicode-bootstrap)) #\?                          #-(and unicode (not unicode-bootstrap)) #\?
773                          #+(and unicode (not unicode-bootstrap)) #\U+FFFD))                          #+(and unicode (not unicode-bootstrap)) #\U+FFFD))
774                     #+unicode                     #+unicode
# Line 788  character and illegal outputs are replac Line 799  character and illegal outputs are replac
799                       (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)                       (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
800                                   (surrogates-to-codepoint (car ,nstate) ,nchar)                                   (surrogates-to-codepoint (car ,nstate) ,nchar)
801                                   (if ,error                                   (if ,error
802                                       (funcall ,error                                       (locally
803                                                (intl:gettext "Cannot convert invalid surrogate #x~X to character")                                           (declare (optimize (ext:inhibit-warnings 3)))
804                                                ,nchar)                                         (funcall ,error
805                                                    (intl:gettext "Cannot convert invalid surrogate #x~X to character")
806                                                    ,nchar))
807                                       +replacement-character-code+)))                                       +replacement-character-code+)))
808                     (setf (car ,nstate) nil))                     (setf (car ,nstate) nil))
809                   ;; A lone trailing (low) surrogate gets replaced with                   ;; A lone trailing (low) surrogate gets replaced with
810                   ;; the replacement character.                   ;; the replacement character.
811                   (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)                   (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
812                               (if ,error                               (if ,error
813                                   (funcall ,error                                   (locally
814                                            (intl:gettext "Cannot convert lone trailing surrogate #x~X to character")                                       (declare (optimize (ext:inhibit-warnings 3)))
815                                            ,nchar)                                     (funcall ,error
816                                                (intl:gettext "Cannot convert lone trailing surrogate #x~X to character")
817                                                ,nchar))
818                                   +replacement-character-code+)                                   +replacement-character-code+)
819                               (char-code ,nchar)))))))))                               (char-code ,nchar)))))))))
820    
# Line 909  character and illegal outputs are replac Line 924  character and illegal outputs are replac
924                   error)                   error)
925        (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))))
926    
927    
928    (def-ef-macro ef-octets-to-string-counted (extfmt lisp::lisp +ef-max+ +ef-osc+)
929      `(lambda (octets ptr end state ocount string s-start s-end error
930                &aux (pos s-start) (last-octet 0))
931         (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
932                  (type (simple-array (unsigned-byte 8) (*)) octets ocount)
933                  (type kernel:index pos end last-octet s-start s-end)
934                  (type (integer -1 (#.array-dimension-limit)) ptr)
935                  (type simple-string string)
936                  (ignorable state))
937         (catch 'end-of-octets
938           (loop for k of-type fixnum from 0
939              while (< pos s-end)
940              do (setf (schar string pos)
941                       (octets-to-char ,extfmt state (aref ocount k)
942                                       (if (>= ptr end)
943                                           (throw 'end-of-octets nil)
944                                           (aref octets (incf ptr)))
945                                       (lambda (n) (decf ptr n))
946                                       error))
947              (incf pos)
948              (incf last-octet (aref ocount k))))
949         (values string pos last-octet state)))
950    
951    ;; Like OCTETS-TO-STRING, but we take an extra argument which is an
952    ;; array which will contain the number of octets read for each
953    ;; character placed in the output string.
954    (defun octets-to-string-counted (octets ocount
955                                     &key (start 0) end (external-format :default)
956                                     (string nil stringp)
957                                     (s-start 0) (s-end nil s-end-p)
958                                     (state nil)
959                                     error)
960      "Octets-to-string converts an array of octets in Octets to a string
961      according to the specified External-format.  The array of octets is
962      bounded by Start (defaulting ot 0) and End (defaulting to the end of
963      the array.  If String is not given, a new string is created.  If
964      String is given, the converted octets are stored in String, starting
965      at S-Start (defaulting to the 0) and ending at S-End (defaulting to
966      the length of String).  If the string is not large enough to hold
967      all of characters, then some octets will not be converted.  A State
968      may also be specified; this is used as the state of the external
969      format.
970    
971      In Ocount, the number of octets read for each character in the
972      string is saved
973    
974      Four values are returned: the string, the number of characters read,
975      the number of octets actually consumed and the new state of the
976      external format."
977      (declare (type (simple-array (unsigned-byte 8) (*)) octets ocount)
978               (type kernel:index start s-start)
979               (type (or kernel:index null) end)
980               (type (or simple-string null) string))
981      (let ((s-end (if s-end-p
982                       s-end
983                       (if stringp
984                           (length string)
985                           (length octets)))))
986        (multiple-value-bind (string pos last-octet new-state)
987            (funcall (ef-octets-to-string-counted external-format)
988                     octets (1- start) (1- (or end (length octets)))
989                     state
990                     ocount
991                     (or string (make-string (length octets)))
992                     s-start s-end
993                     error)
994          (values (if stringp string (lisp::shrink-vector string pos)) (- pos s-start) last-octet new-state))))
995    
996    
997    
998  (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)  (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)

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

  ViewVC Help
Powered by ViewVC 1.1.5