/[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.19 by rtoy, Fri Oct 2 20:15:04 2009 UTC revision 1.20 by rtoy, Sun Oct 18 14:21:23 2009 UTC
# Line 33  Line 33 
33    en                                    ; encode    en                                    ; encode
34    de                                    ; decode    de                                    ; decode
35    flush                                 ; flush state    flush                                 ; flush state
36      copy-state                            ; copy state
37    max)    max)
38    
39  ;; Unicode replacement character U+FFFD  ;; Unicode replacement character U+FFFD
# Line 567  Line 568 
568                              `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))                              `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))
569             (funcall (or (aref (ef-cache ,tmp1) ,tmp2)             (funcall (or (aref (ef-cache ,tmp1) ,tmp2)
570                          (setf (aref (ef-cache ,tmp1) ,tmp2)                          (setf (aref (ef-cache ,tmp1) ,tmp2)
571                              (let ((*compile-print* nil)                                (let ((*compile-print* nil)
572                                    ;; Set default format when we compile so we                                      ;; Set default format when we compile so we
573                                    ;; can see compiler messages.  If we don't,                                      ;; can see compiler messages.  If we don't,
574                                    ;; we run into a problem that we might be                                      ;; we run into a problem that we might be
575                                    ;; changing the default format while we're                                      ;; changing the default format while we're
576                                    ;; compiling, and we don't know how to output                                      ;; compiling, and we don't know how to output
577                                    ;; the compiler messages.                                      ;; the compiler messages.
578                                    #|(*default-external-format* :iso8859-1)|#)                                      #|(*default-external-format* :iso8859-1)|#)
579                                (compile nil `(lambda (%slots%)                                  (compile nil `(lambda (%slots%)
580                                                (declare (ignorable %slots%))                                                 (declare (ignorable %slots%))
581                                                (block ,',blknm                                                 (block ,',blknm
582                                                  ,,body))))))                                                   ,,body))))))
583                      (ef-slots ,tmp1))))                      (ef-slots ,tmp1))))
584         (declaim (inline ,name))         (declaim (inline ,name))
585         (defun ,name (,tmp1)         (defun ,name (,tmp1)
# Line 694  Line 695 
695        (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))        (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
696    
697  (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)  (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)
698    `(lambda (octets ptr end string &aux (pos 0) (count 0) (state nil) (last-octet 0))    `(lambda (octets ptr end state string s-start s-end &aux (pos s-start) (count 0) (last-octet 0))
699       (declare (optimize (speed 3) #|(safety 0) (space 0) (debug 0)|#)       (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
700                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
701                (type kernel:index pos end count last-octet)                (type kernel:index pos end count last-octet s-start s-end)
702                (type (integer -1 (#.array-dimension-limit)) ptr)                (type (integer -1 (#.array-dimension-limit)) ptr)
703                (type simple-string string)                (type simple-string string)
704                (ignorable state))                (ignorable state))
705       (catch 'end-of-octets       (catch 'end-of-octets
706         (loop         (loop while (< pos s-end)
707            (when (= pos (length string))            do (setf (schar string pos)
708              (setq string (adjust-array string (* 2 pos))))                     (octets-to-char ,extfmt state count
709            (setf (schar string pos)                                     (if (>= ptr end)
710                  (octets-to-char ,extfmt state count                                         (throw 'end-of-octets nil)
711                                  (if (>= ptr end)                                         (aref octets (incf ptr)))
712                                      (throw 'end-of-octets nil)                                     (lambda (n) (decf ptr n))))
                                     (aref octets (incf ptr)))  
                                 (lambda (n) (decf ptr n))))  
713            (incf pos)            (incf pos)
714            (incf last-octet count)))            (incf last-octet count)))
715       (values string pos last-octet)))       (values string pos last-octet state)))
716    
717  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
718                                       (string nil stringp))                                       (string nil stringp)
719                                         (s-start 0) (s-end nil s-end-p)
720                                         (state nil))
721    "Octets-to-string converts an array of octets in Octets to a string    "Octets-to-string converts an array of octets in Octets to a string
722    according to the specified External-format.  The array of octets is    according to the specified External-format.  The array of octets is
723    bounded by Start (defaulting ot 0) and End (defaulting to the end of    bounded by Start (defaulting ot 0) and End (defaulting to the end of
724    the array.  If String is given, the string is stored there.  If    the array.  If String is not given, a new string is created.  If
725    String is too short to hold all of the characters, it will be    String is given, the converted octets are stored in String, starting
726    adjusted (via adjust-array).  If String is not given, a new string    at S-Start (defaulting to the 0) and ending at S-End (defaulting to
727    is created.  Three values are returned: the string, the number of    the length of String).  If the string is not large enough to hold
728    characters read, and the number of octets consumed."    all of characters, then some octets will not be converted.  A State
729      may also be specified; this is used as the state of the external
730      format.
731    
732      Four values are returned: the string, the number of characters read,
733      the number of octets actually consumed and the new state of the
734      external format."
735    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
736             (type kernel:index start)             (type kernel:index start s-start)
737             (type (or kernel:index null) end)             (type (or kernel:index null) end)
738             (type (or simple-string null) string))             (type (or simple-string null) string))
739    (multiple-value-bind (string pos last-octet)    (let ((s-end (if s-end-p
740        (funcall (ef-octets-to-string external-format)                     s-end
741                 octets (1- start) (1- (or end (length octets)))                     (if stringp
742                 (or string (make-string (length octets))))                         (length string)
743      (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet)))                         (length octets)))))
744        (multiple-value-bind (string pos last-octet new-state)
745            (funcall (ef-octets-to-string external-format)
746                     octets (1- start) (1- (or end (length octets)))
747                     state
748                     (or string (make-string (length octets)))
749                     s-start s-end)
750          (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))
751    
752    
753    

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20

  ViewVC Help
Powered by ViewVC 1.1.5