X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=089b7597cd602ac131738831d8da05b54533c11a;hb=428b60fff4247e34ff601810f33976908f22bbc0;hp=dfadf540945548c8d384d0b0c15eeff7f96466fd;hpb=ca8272a7473ff5673b2da1ec7b6f9eeb87354a76;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index dfadf54..089b759 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -31,16 +31,10 @@
       (pop *available-buffers*)
       (allocate-system-memory bytes-per-buffer)))
 
-;;;; the FILE-STREAM structure
+;;;; the FD-STREAM structure
 
-(defstruct (file-stream
+(defstruct (fd-stream
 	    (:constructor %make-fd-stream)
-	    ;; KLUDGE: in an ideal world, maybe we'd rewrite
-	    ;; everything to use FILE-STREAM rather than simply
-	    ;; providing this hack for compatibility with the old
-	    ;; code.  However, CVS doesn't deal terribly well with
-	    ;; file renaming, so for now we use this
-	    ;; backward-compatibility feature.
 	    (:conc-name fd-stream-)
 	    (:predicate fd-stream-p)
 	    (:include ansi-stream
@@ -89,7 +83,7 @@
   (pathname nil :type (or pathname null))
   (external-format :default)
   (output-bytes #'ill-out :type function))
-(def!method print-object ((fd-stream file-stream) stream)
+(def!method print-object ((fd-stream fd-stream) stream)
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
     (format stream "for ~S" (fd-stream-name fd-stream))))
@@ -182,7 +176,7 @@
 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 ;;; this would block, queue it.
 (defun frob-output (stream base start end reuse-sap)
-  (declare (type file-stream stream)
+  (declare (type fd-stream stream)
 	   (type (or system-area-pointer (simple-array * (*))) base)
 	   (type index start end))
   (if (not (null (fd-stream-output-later stream))) ; something buffered.
@@ -210,7 +204,7 @@
       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
-(defmacro output-wrapper/variable-width ((stream size buffering)
+(defmacro output-wrapper/variable-width ((stream size buffering restart)
 					 &body body)
   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream)
@@ -224,10 +218,15 @@
 	 `(when (> (fd-stream-ibuf-tail ,stream-var)
 		   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))
-      (with-simple-restart (output-nothing
-			    "~@<Skip output of this character.~@:>")
-	,@body)
-      (incf (fd-stream-obuf-tail ,stream-var) size)
+      ,(if restart
+           
+           `(with-simple-restart (output-nothing
+                                  "~@<Skip output of this character.~@:>")
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) size))
+           `(progn
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) size)))
       ,(ecase (car buffering)
 	 (:none
 	  `(flush-output-buffer ,stream-var))
@@ -237,7 +236,7 @@
 	 (:full))
     (values))))
 
-(defmacro output-wrapper ((stream size buffering) &body body)
+(defmacro output-wrapper ((stream size buffering restart) &body body)
   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream))
       ,(unless (eq (car buffering) :none)
@@ -249,10 +248,14 @@
 	 `(when (> (fd-stream-ibuf-tail ,stream-var)
 		   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))
-       (with-simple-restart (output-nothing
-			    "~@<Skip output of this character.~@:>")
-	 ,@body
-	 (incf (fd-stream-obuf-tail ,stream-var) ,size))
+      ,(if restart
+           `(with-simple-restart (output-nothing
+                                  "~@<Skip output of this character.~@:>")
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) ,size))
+           `(progn
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) ,size)))
       ,(ecase (car buffering)
 	 (:none
 	  `(flush-output-buffer ,stream-var))
@@ -262,9 +265,9 @@
 	 (:full))
     (values))))
 
-(defmacro def-output-routines/variable-width ((name-fmt size external-format
-							&rest bufferings)
-					      &body body)
+(defmacro def-output-routines/variable-width
+    ((name-fmt size restart external-format &rest bufferings)
+     &body body)
   (declare (optimize (speed 1)))
   (cons 'progn
 	(mapcar
@@ -274,7 +277,7 @@
 			       (format nil name-fmt (car buffering))))))
 		`(progn
 		   (defun ,function (stream byte)
-		     (output-wrapper/variable-width (stream ,size ,buffering)
+		     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
 		       ,@body))
 		   (setf *output-routines*
 			 (nconc *output-routines*
@@ -290,7 +293,8 @@
 
 ;;; Define output routines that output numbers SIZE bytes long for the
 ;;; given bufferings. Use BODY to do the actual output.
-(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
+(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
+                               &body body)
   (declare (optimize (speed 1)))
   (cons 'progn
 	(mapcar
@@ -300,7 +304,7 @@
 			       (format nil name-fmt (car buffering))))))
 		`(progn
 		   (defun ,function (stream byte)
-		     (output-wrapper (stream ,size ,buffering)
+		     (output-wrapper (stream ,size ,buffering ,restart)
 		       ,@body))
 		   (setf *output-routines*
 			 (nconc *output-routines*
@@ -314,8 +318,10 @@
 				   (cdr buffering)))))))
 	    bufferings)))
 
+;;; FIXME: is this used anywhere any more?
 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
 		      1
+                      t
 		      (:none character)
 		      (:line character)
 		      (:full character))
@@ -327,6 +333,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
 		      1
+                      nil
 		      (:none (unsigned-byte 8))
 		      (:full (unsigned-byte 8)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -334,6 +341,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
 		      1
+                      nil
 		      (:none (signed-byte 8))
 		      (:full (signed-byte 8)))
   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
@@ -342,6 +350,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
 		      2
+                      nil
 		      (:none (unsigned-byte 16))
 		      (:full (unsigned-byte 16)))
   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -349,6 +358,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
 		      2
+                      nil
 		      (:none (signed-byte 16))
 		      (:full (signed-byte 16)))
   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
@@ -357,6 +367,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
 		      4
+                      nil
 		      (:none (unsigned-byte 32))
 		      (:full (unsigned-byte 32)))
   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -364,6 +375,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
 		      4
+                      nil
 		      (:none (signed-byte 32))
 		      (:full (signed-byte 32)))
   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
@@ -529,7 +541,7 @@
 	      (ecase buffering
 		(:none
 		 (lambda (stream byte)
-		   (output-wrapper (stream (/ i 8) (:none))
+		   (output-wrapper (stream (/ i 8) (:none) nil)
 		     (loop for j from 0 below (/ i 8)
 			   do (setf (sap-ref-8 
 				     (fd-stream-obuf-sap stream)
@@ -537,7 +549,7 @@
 				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 		(:full
 		 (lambda (stream byte)
-		   (output-wrapper (stream (/ i 8) (:full))
+		   (output-wrapper (stream (/ i 8) (:full) nil)
 		     (loop for j from 0 below (/ i 8)
 			   do (setf (sap-ref-8 
 				     (fd-stream-obuf-sap stream)
@@ -552,7 +564,7 @@
 	      (ecase buffering
 		(:none
 		 (lambda (stream byte)
-		   (output-wrapper (stream (/ i 8) (:none))
+		   (output-wrapper (stream (/ i 8) (:none) nil)
 		     (loop for j from 0 below (/ i 8)
 			   do (setf (sap-ref-8 
 				     (fd-stream-obuf-sap stream)
@@ -560,7 +572,7 @@
 				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 		(:full
 		 (lambda (stream byte)
-		   (output-wrapper (stream (/ i 8) (:full))
+		   (output-wrapper (stream (/ i 8) (:full) nil)
 		     (loop for j from 0 below (/ i 8)
 			   do (setf (sap-ref-8 
 				     (fd-stream-obuf-sap stream)
@@ -881,7 +893,7 @@
 ;;; isn't too problematical.
 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
 			       &aux (total-copied 0))
-  (declare (type file-stream stream))
+  (declare (type fd-stream stream))
   (declare (type index start requested total-copied))
   (let ((unread (fd-stream-unread stream)))
     (when unread
@@ -949,11 +961,12 @@
       (when (null count)
         (simple-stream-perror "couldn't read from ~S" stream err))
       (setf (fd-stream-listen stream) nil
-            (fd-stream-ibuf-head stream) new-head
+            (fd-stream-ibuf-head stream) 0
             (fd-stream-ibuf-tail stream) (+ count new-head))
       count)))
 
-(defmacro define-external-format (external-format size out-expr in-expr)
+(defmacro define-external-format (external-format size output-restart
+                                  out-expr in-expr)
   (let* ((name (first external-format))
          (out-function (intern (let ((*print-case* :upcase))
                                  (format nil "OUTPUT-BYTES/~A" name))))
@@ -980,12 +993,17 @@
 			(sap (fd-stream-obuf-sap stream))
 			(tail (fd-stream-obuf-tail stream)))
 		       ((or (= start end) (< (- len tail) 4)) tail)
-		    (with-simple-restart (output-nothing
-					  "~@<Skip output of this character.~@:>")
-		      (let* ((byte (aref string start))
-			     (bits (char-code byte)))
-			,out-expr
-			(incf tail ,size)))
+                    ,(if output-restart
+                         `(with-simple-restart (output-nothing
+                                                "~@<Skip output of this character.~@:>")
+                           (let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,out-expr
+                             (incf tail ,size)))
+                         `(let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,out-expr
+                             (incf tail ,size)))
 		    (incf start)))
 	    (when (< start end)
 	      (flush-output-buffer stream)))
@@ -993,6 +1011,7 @@
 	    (flush-output-buffer stream))))
       (def-output-routines (,format
 			    ,size
+                            ,output-restart
 			    (:none character)
 			    (:line character)
 			    (:full character))
@@ -1005,7 +1024,7 @@
 	  ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
 			   &aux (total-copied 0))
-	(declare (type file-stream stream))
+	(declare (type fd-stream stream))
 	(declare (type index start requested total-copied))
 	(let ((unread (fd-stream-unread stream)))
 	  (when unread
@@ -1052,8 +1071,9 @@
 			 '(:none :line :full)))
 	*external-formats*)))))
 
-(defmacro define-external-format/variable-width (external-format out-size-expr
-						 out-expr in-size-expr in-expr)
+(defmacro define-external-format/variable-width
+    (external-format output-restart out-size-expr
+     out-expr in-size-expr in-expr)
   (let* ((name (first external-format))
 	 (out-function (intern (let ((*print-case* :upcase))
 				 (format nil "OUTPUT-BYTES/~A" name))))
@@ -1094,6 +1114,7 @@
 	    (flush-output-buffer fd-stream))))
       (def-output-routines/variable-width (,format
 					   ,out-size-expr
+                                           ,output-restart
 					   ,external-format
 					   (:none character)
 					   (:line character)
@@ -1107,7 +1128,7 @@
 	  ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
 			   &aux (total-copied 0))
-	(declare (type file-stream stream))
+	(declare (type fd-stream stream))
 	(declare (type index start requested total-copied))
 	(let ((unread (fd-stream-unread stream)))
 	  (when unread
@@ -1201,19 +1222,51 @@
 	*external-formats*)))))
 
 (define-external-format (:latin-1 :latin1 :iso-8859-1)
-    1
+    1 t
   (if (>= bits 256)
       (stream-encoding-error stream bits)
       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
 (define-external-format (:ascii :us-ascii :ansi_x3.4-1968)
-    1
+    1 t
   (if (>= bits 128)
       (stream-encoding-error stream bits)
       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
+(let* ((table (let ((s (make-string 256)))
+		(map-into s #'code-char
+			  '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
+			    #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
+			    #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
+			    #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
+			    #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
+			    #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
+			    #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
+			    #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
+			    #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
+			    #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
+			    #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
+			    #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
+			    #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
+			    #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
+			    #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
+			    #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
+		s))
+       (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
+			  (loop for char across table for i from 0
+			       do (aver (= 0 (aref rt (char-code char))))
+			       do (setf (aref rt (char-code char)) i))
+			  rt)))
+  (define-external-format (:ebcdic-us :ibm-037 :ibm037)
+      1 t
+    (if (>= bits 256)
+	(stream-encoding-error stream bits)
+	(setf (sap-ref-8 sap tail) (aref reverse-table bits)))
+    (aref table byte)))
+    
+
 #!+sb-unicode
 (let ((latin-9-table (let ((table (make-string 256)))
                        (do ((i 0 (1+ i)))
@@ -1235,7 +1288,7 @@
                                      :element-type '(unsigned-byte 8)
                                      :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
   (define-external-format (:latin-9 :latin9 :iso-8859-15)
-      1
+      1 t
     (setf (sap-ref-8 sap tail)
           (if (< bits 256)
               (if (= bits (char-code (aref latin-9-table bits)))
@@ -1246,7 +1299,7 @@
                   (stream-encoding-error stream byte))))
     (aref latin-9-table byte)))
 
-(define-external-format/variable-width (:utf-8 :utf8)
+(define-external-format/variable-width (:utf-8 :utf8) nil
   (let ((bits (char-code byte)))
     (cond ((< bits #x80) 1)
 	  ((< bits #x800) 2)
@@ -1568,7 +1621,7 @@
        ;; appropriate value for the EXPECTED-TYPE slot..
        (error 'simple-type-error
               :datum fd-stream
-              :expected-type 'file-stream
+              :expected-type 'fd-stream
               :format-control "~S is not a stream associated with a file."
               :format-arguments (list fd-stream)))
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
@@ -1585,7 +1638,7 @@
      (fd-stream-file-position fd-stream arg1))))
 
 (defun fd-stream-file-position (stream &optional newpos)
-  (declare (type file-stream stream)
+  (declare (type fd-stream stream)
 	   (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
   (if (null newpos)
       (sb!sys:without-interrupts
@@ -1983,7 +2036,7 @@
 ;;;
 ;;; FIXME: misleading name, screwy interface
 (defun file-name (stream &optional new-name)
-  (when (typep stream 'file-stream)
+  (when (typep stream 'fd-stream)
       (cond (new-name
 	     (setf (fd-stream-pathname stream) new-name)
 	     (setf (fd-stream-file stream)
@@ -2000,7 +2053,7 @@
 ;;;; COMMON-LISP.)
 
 (defun file-string-length (stream object)
-  (declare (type (or string character) object) (type file-stream stream))
+  (declare (type (or string character) object) (type fd-stream stream))
   #!+sb-doc
   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
    OBJECT to STREAM. Non-trivial only in implementations that support
@@ -2011,9 +2064,9 @@
     (string (length object))))
 
 (defun stream-external-format (stream)
-  (declare (type file-stream stream))
+  (declare (type fd-stream stream))
   #!+sb-doc
-  "Return the actual external format for file-streams, otherwise :DEFAULT."
-  (if (typep stream 'file-stream)
+  "Return the actual external format for fd-streams, otherwise :DEFAULT."
+  (if (typep stream 'fd-stream)
       (fd-stream-external-format stream)
       :default))