/[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.18 by rtoy, Sat Sep 19 14:12:22 2009 UTC revision 1.18.4.5 by rtoy, Tue Oct 6 12:48:32 2009 UTC
# Line 567  Line 567 
567                              `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))                              `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))
568             (funcall (or (aref (ef-cache ,tmp1) ,tmp2)             (funcall (or (aref (ef-cache ,tmp1) ,tmp2)
569                          (setf (aref (ef-cache ,tmp1) ,tmp2)                          (setf (aref (ef-cache ,tmp1) ,tmp2)
570                              (let ((*compile-print* nil)                                (let ((*compile-print* nil)
571                                    ;; Set default format when we compile so we                                      ;; Set default format when we compile so we
572                                    ;; can see compiler messages.  If we don't,                                      ;; can see compiler messages.  If we don't,
573                                    ;; we run into a problem that we might be                                      ;; we run into a problem that we might be
574                                    ;; changing the default format while we're                                      ;; changing the default format while we're
575                                    ;; compiling, and we don't know how to output                                      ;; compiling, and we don't know how to output
576                                    ;; the compiler messages.                                      ;; the compiler messages.
577                                    #|(*default-external-format* :iso8859-1)|#)                                      #|(*default-external-format* :iso8859-1)|#)
578                                (compile nil `(lambda (%slots%)                                  (compile nil `(lambda (%slots%)
579                                                (declare (ignorable %slots%))                                                 (declare (ignorable %slots%))
580                                                (block ,',blknm                                                 (block ,',blknm
581                                                  ,,body))))))                                                   ,,body))))))
582                      (ef-slots ,tmp1))))                      (ef-slots ,tmp1))))
583         (declaim (inline ,name))         (declaim (inline ,name))
584         (defun ,name (,tmp1)         (defun ,name (,tmp1)
# Line 694  Line 694 
694        (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))        (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
695    
696  (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+)
697    `(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))
698       (declare (optimize (speed 3) #|(safety 0) (space 0) (debug 0)|#)       (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
699                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
700                (type kernel:index pos end count last-octet)                (type kernel:index pos end count last-octet s-start s-end)
701                (type (integer -1 (#.array-dimension-limit)) ptr)                (type (integer -1 (#.array-dimension-limit)) ptr)
702                (type simple-string string)                (type simple-string string)
703                (ignorable state))                (ignorable state))
704       (catch 'end-of-octets       (catch 'end-of-octets
705         (loop         (loop while (< pos s-end)
706            (when (= pos (length string))            do (setf (schar string pos)
707              (setq string (adjust-array string (* 2 pos))))                     (octets-to-char ,extfmt state count
708            (setf (schar string pos)                                     (if (>= ptr end)
709                  (octets-to-char ,extfmt state count                                         (throw 'end-of-octets nil)
710                                  (if (>= ptr end)                                         (bref octets (incf ptr)))
711                                      (throw 'end-of-octets nil)                                     (lambda (n) (decf ptr n))))
                                     (aref octets (incf ptr)))  
                                 (lambda (n) (decf ptr n))))  
712            (incf pos)            (incf pos)
713            (incf last-octet count)))            (incf last-octet count)))
714       (values string pos last-octet)))       (values string pos last-octet state)))
715    
716  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
717                                       (string nil stringp))                                       (string nil stringp)
718                                         (s-start 0) (s-end nil s-end-p)
719                                         (state nil))
720    "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
721    according to the specified External-format.  The array of octets is    according to the specified External-format.  The array of octets is
722    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
# Line 726  Line 726 
726    is created.  Three values are returned: the string, the number of    is created.  Three values are returned: the string, the number of
727    characters read, and the number of octets consumed."    characters read, and the number of octets consumed."
728    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
729             (type kernel:index start)             (type kernel:index start s-start)
730             (type (or kernel:index null) end)             (type (or kernel:index null) end)
731             (type (or simple-string null) string))             (type (or simple-string null) string))
732    (multiple-value-bind (string pos last-octet)    (let ((s-end (if s-end-p
733        (funcall (ef-octets-to-string external-format)                     s-end
734                 octets (1- start) (1- (or end (length octets)))                     (if stringp
735                 (or string (make-string (length octets))))                         (length string)
736      (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet)))                         (length octets)))))
737        (multiple-value-bind (string pos last-octet new-state)
738            (funcall (ef-octets-to-string external-format)
739                     octets (1- start) (1- (or end (length octets)))
740                     state
741                     (or string (make-string (length octets)))
742                     s-start s-end)
743          (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))
744    
745    
746    

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.18.4.5

  ViewVC Help
Powered by ViewVC 1.1.5