CMUCL commit: src/code (extfmts.lisp fd-stream.lisp)

[Raymond Toy]

    Date: Friday, July 2, 2010 @ 19:06:26
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/code

Modified: extfmts.lisp fd-stream.lisp

code/extfmts.lisp:
o Pass the error handler on for composed external formats.

code/fd-stream.lisp:
o Forgot to pass the error-handler to char-to-octets in EF-COUT.
o In MAKE-FD-STREAM slightly change handling of encoding-error and
  decoding-error: 
  - If :encoding-error is a character, then the external format will
    use that character whenever an encoding error happens instead of
    the default (internally specified by the external format).
  - If :decoding-error is a character, then the external format will
    use that character whenever an encoding error happens instead of
    the default (internally specified by the external format).  If
    :decoding-error is T, then a cerror is signaled; if continued, the
    Unicode replacement character (#\U+FFFD) is used.
o Fix bug in OPEN:  The :decoding-error and :encoding-error keyword
  parameter was placed in the &aux section by mistake.


----------------+
 extfmts.lisp   |   10 +++++-----
 fd-stream.lisp |   43 +++++++++++++++++++++++++++++--------------
 2 files changed, 34 insertions(+), 19 deletions(-)


Index: src/code/extfmts.lisp
diff -u src/code/extfmts.lisp:1.28 src/code/extfmts.lisp:1.29
--- src/code/extfmts.lisp:1.28	Fri Jul  2 12:29:55 2010
+++ src/code/extfmts.lisp	Fri Jul  2 19:06:26 2010
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.28 2010-07-02 16:29:55 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.29 2010-07-02 23:06:26 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -384,16 +384,16 @@
   (make-external-format
    (%composed-ef-name (ef-name a) (ef-name b))
    (make-efx
-    :octets-to-code (lambda (state input unput)
+    :octets-to-code (lambda (state input unput error)
 		      (let ((nstate (gensym "STATE-")))
 			`(let ((,nstate ,state))
 			   (when (null ,nstate)
 			     (setq ,nstate (setf ,state (cons nil nil))))
 			   ,(funcall (ef-octets-to-code b) `(car ,nstate)
 				     (funcall (ef-octets-to-code a)
-					      `(cdr ,nstate) input unput)
+					      `(cdr ,nstate) input unput error)
 				     unput))))
-    :code-to-octets (lambda (code state output)
+    :code-to-octets (lambda (code state output error)
 		      (let ((nstate (gensym "STATE-")))
 			`(let ((,nstate ,state))
 			   (when (null ,nstate)
@@ -401,7 +401,7 @@
 			   ,(funcall (ef-code-to-octets b) code `(car ,nstate)
 				     `(lambda (x)
 				       ,(funcall (ef-code-to-octets a)
-						 'x `(cdr ,nstate) output))))))
+						 'x `(cdr ,nstate) output error))))))
     :cache (make-array +ef-max+ :initial-element nil)
     :min (* (ef-min-octets a) (ef-min-octets b))
     :max (* (ef-max-octets a) (ef-max-octets b)))
Index: src/code/fd-stream.lisp
diff -u src/code/fd-stream.lisp:1.105 src/code/fd-stream.lisp:1.106
--- src/code/fd-stream.lisp:1.105	Fri Jul  2 12:29:55 2010
+++ src/code/fd-stream.lisp	Fri Jul  2 19:06:26 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.105 2010-07-02 16:29:55 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.106 2010-07-02 23:06:26 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -590,7 +590,8 @@
 				   (do-output stream sap 0 tail t)
 				   (setq sap (fd-stream-obuf-sap stream)
 					 tail 0))
-				 (setf (bref sap (1- (incf tail))) byte)))
+				 (setf (bref sap (1- (incf tail))) byte))
+			       (fd-stream-char-to-octets-error stream))
        (setf (fd-stream-obuf-tail stream) tail))
     (if (char= char #\Newline)
 	(setf (fd-stream-char-pos stream) 0)
@@ -1816,16 +1817,30 @@
 					      :pathname pathname
 					      :buffering buffering
 					      :timeout timeout)
-		    (%make-fd-stream :fd fd
-				     :name name
-				     :file file
-				     :original original
-				     :delete-original delete-original
-				     :pathname pathname
-				     :buffering buffering
-				     :timeout timeout
-				     :char-to-octets-error encoding-error
-				     :octets-to-char-error decoding-error))))
+		    (let ((e (cond ((characterp encoding-error)
+				    (constantly (char-code encoding-error)))
+				   (t
+				    encoding-error)))
+			  (d (cond ((characterp decoding-error)
+				    (constantly (char-code decoding-error)))
+				   ((eq t decoding-error)
+				    #'(lambda (&rest args)
+					(apply 'cerror
+					       "Use Unicode replacement character instead"
+					       args)
+					stream:+replacement-character-code+))
+				   (t
+				    decoding-error))))
+		      (%make-fd-stream :fd fd
+				       :name name
+				       :file file
+				       :original original
+				       :delete-original delete-original
+				       :pathname pathname
+				       :buffering buffering
+				       :timeout timeout
+				       :char-to-octets-error e
+				       :octets-to-char-error d)))))
     ;; FIXME: setting the external format here should be better
     ;; integrated into set-routines.  We do it before so that
     ;; set-routines can create an in-buffer if appropriate.  But we
@@ -2153,13 +2168,13 @@
 			   (if-does-not-exist nil if-does-not-exist-given)
 			   (external-format :default)
 			   class mapped input-handle output-handle
+	                   decoding-error encoding-error
 		      &allow-other-keys
 		      &aux ; Squelch assignment warning.
 		      (options options)
 		      (direction direction)
 		      (if-does-not-exist if-does-not-exist)
-		      (if-exists if-exists)
-	              decoding-error encoding-error)
+		      (if-exists if-exists))
   "Return a stream which reads from or writes to Filename.
   Defined keywords:
    :direction - one of :input, :output, :io, or :probe