diff --git a/code/conditions.lisp b/code/conditions.lisp index 055370b..2977b0f 100644 --- a/code/conditions.lisp +++ b/code/conditions.lisp @@ -24,20 +24,35 @@ (open-fail-message condition))))) (define-condition transcode-error (stream-error) - ((octets :reader transcode-error-reader + ()) + +(define-condition decode-error (stream-error) + ((octets :reader decode-error-octets :initform nil :initarg :octets))) -(define-condition illegal-sequence (transcode-error) +(define-condition encode-error (stream-error) + ((element :reader encode-error-element + :initform nil + :initarg :element))) + +(define-condition illegal-sequence (decode-error) () (:report (lambda (condition stream) (format stream "Illegal sequence ~s while decoding from ~s" - (transcode-error-octets condition) + (decode-error-octets condition) (stream-error-stream condition))))) (define-condition unexpected-eof (transcode-error) () (:report (lambda (condition stream) (format stream "Unexpected EOF in sequence ~s while decoding from ~s" - (transcode-error-octets condition) + (decode-error-octets condition) + (stream-error-stream condition))))) + +(define-condition invalid-element (encode-error) + () + (:report (lambda (condition stream) + (format stream "The element ~s cannot be encoded to ~s" + (encode-error-element condition) (stream-error-stream condition))))) diff --git a/code/default-methods.lisp b/code/default-methods.lisp index de212bf..eea126f 100644 --- a/code/default-methods.lisp +++ b/code/default-methods.lisp @@ -167,7 +167,7 @@ (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) column) - (let ((current (line-column stream))) + (let ((current (stream-line-column stream))) (when current (dotimes (i (- column current)) (stream-write-char stream #\Newline)) diff --git a/code/echo-stream.lisp b/code/echo-stream.lisp index 6539eef..3ba1d43 100644 --- a/code/echo-stream.lisp +++ b/code/echo-stream.lisp @@ -80,9 +80,9 @@ (defmethod stream-read-line ((stream echo-stream)) (multiple-value-bind (line missing-newline-p) (stream-read-line (echo-stream-input-stream stream)) - (if missing-newline-p - (stream-write-string (echo-stream-output-stream stream) line) - (stream-write-line (echo-stream-output-stream stream) line)) + (stream-write-string (echo-stream-output-stream stream) line) + (unless missing-newline-p + (stream-terpri (echo-stream-output-stream stream))) (values line missing-newline-p))) (defmethod stream-fresh-line ((stream echo-stream)) diff --git a/code/interface.lisp b/code/interface.lisp index c711f33..9e1176a 100644 --- a/code/interface.lisp +++ b/code/interface.lisp @@ -9,7 +9,9 @@ ;;; Gray Streams classes. (defclass fundamental-stream (stream) - ((%openp :initform t :accessor stream-open-p)) + ((%openp :accessor stream-open-p + :initform t + :type boolean)) (:documentation "The base class for all Gray streams.")) (defclass fundamental-input-stream (fundamental-stream) @@ -22,27 +24,37 @@ (defclass fundamental-character-stream (fundamental-stream) () - (:documentation "A superclass of all Gray streams whose element-type is a subtype of character.")) + (:documentation "A superclass of all Gray streams whose element-type is a subtype of + character.")) (defclass fundamental-binary-stream (fundamental-stream) () - (:documentation "A superclass of all Gray streams whose element-type is a subtype of unsigned-byte or signed-byte.")) + (:documentation "A superclass of all Gray streams whose element-type is a subtype of + unsigned-byte or signed-byte.")) -(defclass fundamental-character-input-stream (fundamental-input-stream fundamental-character-stream) +(defclass fundamental-character-input-stream + (fundamental-input-stream fundamental-character-stream) () - (:documentation "A superclass of all Gray input streams whose element-type is a subtype of unsigned-byte or signed-byte.")) + (:documentation "A superclass of all Gray input streams whose element-type is a +subtype of unsigned-byte or signed-byte.")) -(defclass fundamental-character-output-stream (fundamental-output-stream fundamental-character-stream) +(defclass fundamental-character-output-stream + (fundamental-output-stream fundamental-character-stream) () - (:documentation "A superclass of all Gray output streams whose element-type is a subtype of character.")) + (:documentation "A superclass of all Gray output streams whose element-type is a +subtype of character.")) -(defclass fundamental-binary-input-stream (fundamental-input-stream fundamental-binary-stream) +(defclass fundamental-binary-input-stream + (fundamental-input-stream fundamental-binary-stream) () - (:documentation "A superclass of all Gray input streams whose element-type is a subtype of unsigned-byte or signed-byte.")) + (:documentation "A superclass of all Gray input streams whose element-type is a +subtype of unsigned-byte or signed-byte.")) -(defclass fundamental-binary-output-stream (fundamental-output-stream fundamental-binary-stream) +(defclass fundamental-binary-output-stream + (fundamental-output-stream fundamental-binary-stream) () - (:documentation "A superclass of all Gray output streams whose element-type is a subtype of unsigned-byte or signed-byte.")) + (:documentation "A superclass of all Gray output streams whose element-type is a +subtype of unsigned-byte or signed-byte.")) ;;; Gray stream generic functions @@ -209,7 +221,15 @@ (error 'stream-error :stream object))) (defun check-character-stream (object) - (unless (subtypep (stream-element-type object) 'character) + ;; This bizarre logic is needed because CL:FILE-STREAM-LENGTH is + ;; required to return 1 for an empty broadcast stream while + ;; CL:STREAM-ELEMENT-TYPE is required to return T. These two + ;; requirements are contradictions, but the former normally requires + ;; a character stream, but the latter means that it is not a + ;; character stream. + (unless (or (subtypep (stream-element-type object) 'character) + (and (typep object 'broadcast-stream) + (null (broadcast-stream-streams object)))) (error 'stream-error :stream object))) (defun check-binary-stream (object) @@ -368,7 +388,7 @@ (defun ,(ensure-symbol '#:file-position intrinsic-pkg) (stream &optional (position-spec nil position-spec-p)) - (check-type stream stream) + (check-stream stream) (cond (position-spec-p (check-type position-spec (or (integer 0) (member :start :end))) (stream-file-position stream position-spec)) @@ -377,12 +397,13 @@ (defun ,(ensure-symbol '#:file-length intrinsic-pkg) (stream) - (check-type stream stream) + (check-stream stream) (stream-file-length stream)) (defun ,(ensure-symbol '#:file-string-length intrinsic-pkg) (stream object) - (check-type stream stream) + (check-output-stream stream) + (check-character-stream stream) (check-type object (or string character)) (when (characterp object) (setf object (string object))) diff --git a/code/posix-file-stream.lisp b/code/posix-file-stream.lisp index f8709be..f97fe21 100644 --- a/code/posix-file-stream.lisp +++ b/code/posix-file-stream.lisp @@ -38,7 +38,7 @@ :type boolean))) (defmethod truename ((stream posix-file-stream)) - (let ((path (or (temp-pathname stream) (%pathname stream)))) + (let ((path (or (temp-pathname stream) (pathname stream)))) (if path (truename path) nil))) @@ -134,7 +134,8 @@ (case direction ((:input :probe) (if exists - #+sbcl (setf descriptor (sb-posix:open name sb-posix:o-rdonly)) + #+sbcl (setf (descriptor stream) + (sb-posix:open name sb-posix:o-rdonly)) (case if-does-not-exist (:error (error 'file-does-not-exist :pathname path)) @@ -145,7 +146,7 @@ (return-from make-file-stream nil))))) (otherwise (when (and (eq if-exists :new-version) (eq if-does-not-exist :create)) - (setf exist nil)) + (setf exists nil)) (setf flags (if (eq direction :io) sb-posix:o-rdwr sb-posix:o-wronly)) diff --git a/code/stream.lisp b/code/stream.lisp index d5b7c31..e9ab287 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -225,7 +225,8 @@ *default-binary-external-format*) ((subtypep element-type 'character) *default-character-external-format*) - (error "Unknown element type ~s" element-type)) + (t + (error "Unknown element type ~s" element-type))) element-type (if (listp external-format) (cdr external-format) diff --git a/code/string-stream.lisp b/code/string-stream.lisp index 0f8bf0c..3431e20 100644 --- a/code/string-stream.lisp +++ b/code/string-stream.lisp @@ -14,7 +14,8 @@ (defmethod initialize-instance :after ((instance string-output-stream) &rest initargs) (declare (ignore initargs)) (unless (array-has-fill-pointer-p (string-stream-string instance)) - (error "~S must be a string with a fill-pointer" string))) + (error "~S must be a string with a fill-pointer" + (string-stream-string instance)))) (defun make-string-output-stream (&key (element-type 'character)) (when (not (subtypep element-type 'character)) diff --git a/code/transcode/common.lisp b/code/transcode/common.lisp index 8b848e0..440fc3f 100644 --- a/code/transcode/common.lisp +++ b/code/transcode/common.lisp @@ -13,3 +13,6 @@ (or (replacement transcoder) (error 'unexpected-eof :stream stream :octets octets))) +(defun invalid-element (transcoder stream element) + (or (replacement transcoder) + (error 'invalid-element :stream stream :element element))) diff --git a/code/transcode/utf-8.lisp b/code/transcode/utf-8.lisp index fa6cc56..f45fc80 100644 --- a/code/transcode/utf-8.lisp +++ b/code/transcode/utf-8.lisp @@ -8,7 +8,7 @@ :eof) ((< octet1 #b10000000) (coerce (code-char octet1) (stream-element-type stream))) - ((eq (setf octet2 (stream-read-octet input-stream)) :eof) + ((eq (setf octet2 (stream-read-octet stream)) :eof) (unexpected-eof transcoder stream octet1)) ((not (<= #b10000000 octet2 #b10111111)) (illegal-sequence transcoder stream octet1 octet2)) @@ -16,7 +16,7 @@ (coerce (code-char (+ (ash (- octet1 #b11000000) -2) (- octet2 #b10000000))) (stream-element-type stream))) - ((eq (setf octet3 (stream-read-octet input-stream)) :eof) + ((eq (setf octet3 (stream-read-octet stream)) :eof) (unexpected-eof transcoder stream octet1 octet2)) ((not (<= #b10000000 octet3 #b10111111)) (illegal-sequence transcoder stream octet1 octet2 octet3)) @@ -25,7 +25,7 @@ (ash (- octet2 #b10000000) -2) (- octet3 #b10000000))) (stream-element-type stream))) - ((eq (setf octet4 (stream-read-octet input-stream)) :eof) + ((eq (setf octet4 (stream-read-octet stream)) :eof) (unexpected-eof transcoder stream octet1 octet2 octet3)) ((not (and (<= #b10000000 octet4 #b10111111) (< octet1 #b11111000))) diff --git a/cyclosis.asd b/cyclosis.asd index a0b9850..a70f997 100644 --- a/cyclosis.asd +++ b/cyclosis.asd @@ -20,6 +20,8 @@ :serial t :components ((:file "common") (:file "character") + (:file "ascii") + (:file "iso-8859-1") (:file "utf-8") (:file "utf-32") (:file "unsigned-byte")))))))