Author: hhubner Date: Thu May 8 12:18:11 2008 New Revision: 13
Modified: branches/hans/input.lisp branches/hans/output.lisp Log: Incorporate review comments from Edi
Modified: branches/hans/input.lisp ============================================================================== --- branches/hans/input.lisp (original) +++ branches/hans/input.lisp Thu May 8 12:18:11 2008 @@ -242,40 +242,39 @@ (decf position) (push #.(char-code #\Return) octet-stack)))))
+(declaim (inline code-char-with-newline-processing)) (defun code-char-with-newline-processing (char-code eol-style read-char-code-fn unread-char-code-fn) "Perform newline conversion during octets-to-string processing. CHAR-CODE is the code of the current character. If it denotes a -#\Return character, newline processing accoring to EOL-STYLE is +#\Return character, newline processing according to EOL-STYLE is performed. READ-CHAR-CODE-FN and UNREAD-CHAR-CODE-FN are called to read the next character code from the input, unread-char-code-fn is called to skip back in the input by one octet. All this works under the assumption that #\Return and #\Linefeed are single-octet codes." - (declare (optimize speed (safety 0)) - (type fixnum char-code) - (type symbol eol-style)) - (let ((char (code-char char-code))) - (if (eql char #\Return) - (case eol-style - (:cr - #\Newline) - (:crlf - (case (funcall read-char-code-fn) - (:eof - :eof) - (#.(char-code #\Newline) - #\Newline) - (t - (funcall unread-char-code-fn) - #\Return))) - (t - #\Return)) - char))) -(declaim (inline code-char-with-newline-processing)) + (if (eql char-code :eof) + (return-from code-char-with-newline-processing :eof) + (let ((char (code-char char-code))) + (if (eql char #\Return) + (case eol-style + (:cr + #\Newline) + (:crlf + (case (funcall read-char-code-fn) + (:eof + :eof) + (#.(char-code #\Linefeed) + #\Newline) + (t + (funcall unread-char-code-fn) + #\Return))) + (t + #\Return)) + char))))
-(defmacro define-char-reader ((stream-var stream-class) &body body) +(defmacro define-char-reader ((stream stream-class) &body body) "Helper macro to define methods for STREAM-READ-CHAR and OCTETS-TO-STRING%. Defines a method for the class STREAM-CLASS using -the variable STREAM-VAR and the code body BODY wrapped with some +the variable STREAM and the code body BODY wrapped with some standard code common to all methods defined here. The return value of BODY is a character code. In case of encoding problems, BODY must return the value returned by (RECOVER-FROM-ENCODING-ERROR ...). In @@ -284,15 +283,15 @@ the second argument being the vector of octets to convert and the BEGIN and END keyword arguments which can be used to limit the conversion to a subsequence of the octet vector." - (with-unique-names (char-code body-fn octets-var) + (with-unique-names (char-code body-fn octets) (let ((body body)) `(progn - (defmethod stream-read-char ((,stream-var ,stream-class)) + (defmethod stream-read-char ((,stream ,stream-class)) "This method was generated with the DEFINE-CHAR-READER macro." (declare (optimize speed)) (with-accessors ((last-octet flexi-stream-last-octet) (last-char-code flexi-stream-last-char-code)) - ,stream-var + ,stream ;; set LAST-OCTET slot to NIL because we can't UNREAD-BYTE after ;; this operation (setq last-octet nil) @@ -304,16 +303,18 @@ ;; for UNREAD-CHAR (setq last-char-code ,char-code) (or (code-char ,char-code) ,char-code)))) - (defmethod octets-to-string% ((,stream-var ,stream-class) ,octets-var &key start end) + (defmethod octets-to-string% ((,stream ,stream-class) ,octets &key start end) (let ((position start) save-position - (eol-style (external-format-eol-style (flexi-stream-external-format ,stream-var))) - (string (make-array (- end start) :element-type 'character :fill-pointer 0))) + (eol-style (external-format-eol-style (flexi-stream-external-format ,stream))) + (string (make-array (- end start) + :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char + :fill-pointer 0))) ;; High-speed version of OCTETS-TO-STRING: We need to ;; implement this as a macro as we want to stay with the ;; old "inner" API for bodies of character readers. In ;; particular, they shall be able to call (READ-BYTE* - ;; STREAM) as before. To achive this, we create a local + ;; STREAM) as before. To achieve this, we create a local ;; function READ-BYTE* that gets the next byte from the ;; input vector. Additionally, we create local functions ;; for reading characters in a loop and for unreading a @@ -323,7 +324,7 @@ (declare (ignore stream)) (when (< position end) (prog1 - (aref ,octets-var position) + (aref ,octets position) (incf position)))) (read-char-code () (setf save-position position) @@ -331,15 +332,15 @@ ,@body)) (unread-char-code () (setf position save-position))) - (do ((char-code (read-char-code) (read-char-code))) - ((eql char-code :eof) - string) - (vector-push (or (code-char-with-newline-processing char-code - eol-style - #'read-char-code - #'unread-char-code) - char-code) - string))))))))) + (loop + for char = (code-char-with-newline-processing (read-char-code) + eol-style + #'read-char-code + #'unread-char-code) + until (eql char :eof) + do (format t "char ~S~%" char) + do (vector-push char string)) + string)))))))
(defun recover-from-encoding-error (flexi-stream format-control &rest format-args) "Helper function used by the STREAM-READ-CHAR methods below to deal
Modified: branches/hans/output.lisp ============================================================================== --- branches/hans/output.lisp (original) +++ branches/hans/output.lisp Thu May 8 12:18:11 2008 @@ -78,26 +78,26 @@ (declare (optimize speed)) (char-to-octets stream char stream))
-(defmacro define-char-writer (((stream-var stream-class) char-var sink-var) &body body) +(defmacro define-char-writer (((stream stream-class) char sink) &body body) (let ((body body)) - (with-unique-names (string-var start-var end-var dummy-sink-var byte-var i-var) + (with-unique-names (string start end dummy-sink byte i) `(progn - (defmethod char-to-octets ((,stream-var ,stream-class) ,char-var ,sink-var) + (defmethod char-to-octets ((,stream ,stream-class) ,char ,sink) (declare (optimize speed)) ,@body) - (defmethod string-to-octets% ((,stream-var ,stream-class) ,string-var ,start-var ,end-var) + (defmethod string-to-octets% ((,stream ,stream-class) ,string ,start ,end) (declare (optimize speed)) - (let ((,sink-var (make-array (truncate (* (float (- ,end-var ,start-var)) - (flexi-stream-output-size-factor ,stream-var))) - :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)))) + (let ((,sink (make-array (truncate (* (- ,end ,start) + (flexi-stream-output-size-factor ,stream))) + :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)))) (loop - for ,i-var of-type fixnum from ,start-var below ,end-var - for ,char-var of-type character = (aref ,string-var ,i-var) - do (flet ((write-byte* (,byte-var ,dummy-sink-var) - (declare (ignore ,dummy-sink-var)) - (vector-push-extend ,byte-var ,sink-var))) + for ,i of-type fixnum from ,start below ,end + for ,char of-type character = (aref ,string ,i) + do (flet ((write-byte* (,byte ,dummy-sink) + (declare (ignore ,dummy-sink)) + (vector-push-extend ,byte ,sink))) ,@body)) - ,sink-var)))))) + ,sink))))))
(define-char-writer ((stream flexi-latin-1-output-stream) char sink) (let ((octet (char-code char))) @@ -125,31 +125,31 @@ (define-char-writer ((stream flexi-utf-8-output-stream) char sink) (let ((char-code (char-code char))) (tagbody - (cond ((< char-code #x80) - (write-byte* char-code sink) - (go zero)) - ((< char-code #x800) - (write-byte* (logior #b11000000 (ldb (byte 5 6) char-code)) sink) - (go one)) - ((< char-code #x10000) - (write-byte* (logior #b11100000 (ldb (byte 4 12) char-code)) sink) - (go two)) - ((< char-code #x200000) - (write-byte* (logior #b11110000 (ldb (byte 3 18) char-code)) sink) - (go three)) - ((< char-code #x4000000) - (write-byte* (logior #b11111000 (ldb (byte 2 24) char-code)) sink) - (go four)) - (t (write-byte* (logior #b11111100 (ldb (byte 1 30) char-code)) sink))) - (write-byte* (logior #b10000000 (ldb (byte 6 24) char-code)) sink) + (cond ((< char-code #x80) + (write-byte* char-code sink) + (go zero)) + ((< char-code #x800) + (write-byte* (logior #b11000000 (ldb (byte 5 6) char-code)) sink) + (go one)) + ((< char-code #x10000) + (write-byte* (logior #b11100000 (ldb (byte 4 12) char-code)) sink) + (go two)) + ((< char-code #x200000) + (write-byte* (logior #b11110000 (ldb (byte 3 18) char-code)) sink) + (go three)) + ((< char-code #x4000000) + (write-byte* (logior #b11111000 (ldb (byte 2 24) char-code)) sink) + (go four)) + (t (write-byte* (logior #b11111100 (ldb (byte 1 30) char-code)) sink))) + (write-byte* (logior #b10000000 (ldb (byte 6 24) char-code)) sink) four - (write-byte* (logior #b10000000 (ldb (byte 6 18) char-code)) sink) + (write-byte* (logior #b10000000 (ldb (byte 6 18) char-code)) sink) three - (write-byte* (logior #b10000000 (ldb (byte 6 12) char-code)) sink) + (write-byte* (logior #b10000000 (ldb (byte 6 12) char-code)) sink) two - (write-byte* (logior #b10000000 (ldb (byte 6 6) char-code)) sink) + (write-byte* (logior #b10000000 (ldb (byte 6 6) char-code)) sink) one - (write-byte* (logior #b10000000 (ldb (byte 6 0) char-code)) sink) + (write-byte* (logior #b10000000 (ldb (byte 6 0) char-code)) sink) zero)) char)
@@ -202,7 +202,7 @@ (case (external-format-eol-style external-format) (:cr (call-next-method stream #\Return sink)) (:crlf (call-next-method stream #\Return sink) - (call-next-method stream #\Linefeed sink)))) + (call-next-method stream #\Linefeed sink)))) (otherwise (call-next-method))) char))