Add ASCII and ISO-8859-1 transcoders

Also fix some errors

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)))))

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))

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))

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)))

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))

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)

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))

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)))

code/transcode/utf-8.lisp

@@ -8,15 +8,15 @@
            :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))
           ((< octet1 #b11100000)
            (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)))

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")))))))