X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=d8a2d5799d90e36d7c54a022c9e796c0dd95d90d;hb=96a1badea2523bf188f7ba023e2f69a6785847d6;hp=2dee43a53fdd99c6eb08fd896df5489dddd43a23;hpb=696e38f7210c587ba0b54795f4795f58e62fed2d;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 2dee43a..d8a2d57 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -197,6 +197,30 @@
       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
+(defmacro output-wrapper ((stream size buffering) &body body)
+  (let ((stream-var (gensym)))
+    `(let ((,stream-var ,stream))
+      ,(unless (eq (car buffering) :none)
+	 `(when (< (fd-stream-obuf-length ,stream-var)
+	           (+ (fd-stream-obuf-tail ,stream-var)
+		       ,size))
+            (flush-output-buffer ,stream-var)))
+      ,(unless (eq (car buffering) :none)
+	 `(when (> (fd-stream-ibuf-tail ,stream-var)
+		   (fd-stream-ibuf-head ,stream-var))
+            (file-position ,stream-var (file-position ,stream-var))))
+    
+      ,@body
+      (incf (fd-stream-obuf-tail ,stream-var) ,size)
+      ,(ecase (car buffering)
+	 (:none
+	  `(flush-output-buffer ,stream-var))
+	 (:line
+	  `(when (eq (char-code byte) (char-code #\Newline))
+	     (flush-output-buffer ,stream-var)))
+	 (:full))
+    (values))))
+
 ;;; 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)
@@ -209,27 +233,8 @@
 			       (format nil name-fmt (car buffering))))))
 		`(progn
 		   (defun ,function (stream byte)
-		     ,(unless (eq (car buffering) :none)
-			`(when (< (fd-stream-obuf-length stream)
-				  (+ (fd-stream-obuf-tail stream)
-				     ,size))
-			   (flush-output-buffer stream)))
-		     ,(unless (eq (car buffering) :none)
-			`(when (> (fd-stream-ibuf-tail stream)
-				  (fd-stream-ibuf-head stream))
-			   (file-position stream (file-position stream))))
-		     
-		     ,@body
-		     (incf (fd-stream-obuf-tail stream) ,size)
-		     ,(ecase (car buffering)
-			(:none
-			 `(flush-output-buffer stream))
-			(:line
-			 `(when (eq (char-code byte) (char-code #\Newline))
-			    (flush-output-buffer stream)))
-			(:full
-			 ))
-		     (values))
+		     (output-wrapper (stream ,size ,buffering)
+		       ,@body))
 		   (setf *output-routines*
 			 (nconc *output-routines*
 				',(mapcar
@@ -411,9 +416,60 @@
   (dolist (entry *output-routines*)
     (when (and (subtypep type (car entry))
 	       (eq buffering (cadr entry)))
-      (return (values (symbol-function (caddr entry))
-		      (car entry)
-		      (cadddr entry))))))
+      (return-from pick-output-routine
+	(values (symbol-function (caddr entry))
+		(car entry)
+		(cadddr entry)))))
+  ;; KLUDGE: dealing with the buffering here leads to excessive code
+  ;; explosion.
+  ;;
+  ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
+  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+	if (subtypep type `(unsigned-byte ,i))
+	do (return-from pick-output-routine
+	     (values
+	      (ecase buffering
+		(:none
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:none))
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+		(:full
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:full))
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+	      `(unsigned-byte ,i)
+	      (/ i 8))))
+  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+	if (subtypep type `(signed-byte ,i))
+	do (return-from pick-output-routine
+	     (values
+	      (ecase buffering
+		(:none
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:none))
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+		(:full
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:full))
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+	      `(signed-byte ,i)
+	      (/ i 8)))))
 
 ;;;; input routines and related noise
 
@@ -518,7 +574,7 @@
 	   (let ((,element-var
 		  (catch 'eof-input-catcher
 		    (input-at-least ,stream-var ,bytes)
-		    ,@read-forms)))
+		    (locally ,@read-forms))))
 	     (cond (,element-var
 		    (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
 		    ,element-var)
@@ -579,9 +635,45 @@
 (defun pick-input-routine (type)
   (dolist (entry *input-routines*)
     (when (subtypep type (car entry))
-      (return (values (symbol-function (cadr entry))
-		      (car entry)
-		      (caddr entry))))))
+      (return-from pick-input-routine
+	(values (symbol-function (cadr entry))
+		(car entry)
+		(caddr entry)))))
+  ;; FIXME: let's do it the hard way, then (but ignore things like
+  ;; endianness, efficiency, and the necessary coupling between these
+  ;; and the output routines).  -- CSR, 2004-02-09
+  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+	if (subtypep type `(unsigned-byte ,i))
+	do (return-from pick-input-routine
+	     (values
+	      (lambda (stream eof-error eof-value)
+		(input-wrapper (stream (/ i 8) eof-error eof-value)
+		  (let ((sap (fd-stream-ibuf-sap stream))
+			(head (fd-stream-ibuf-head stream)))
+		    (loop for j from 0 below (/ i 8)
+			  with result = 0
+			  do (setf result
+				   (+ (* 256 result)
+				      (sap-ref-8 sap (+ head j))))
+			  finally (return result)))))
+	      `(unsigned-byte ,i)
+	      (/ i 8))))
+  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+	if (subtypep type `(signed-byte ,i))
+	do (return-from pick-input-routine
+	     (values
+	      (lambda (stream eof-error eof-value)
+		(input-wrapper (stream (/ i 8) eof-error eof-value)
+		  (let ((sap (fd-stream-ibuf-sap stream))
+			(head (fd-stream-ibuf-head stream)))
+		    (loop for j from 0 below (/ i 8)
+			  with result = 0
+			  do (setf result
+				   (+ (* 256 result)
+				      (sap-ref-8 sap (+ head j))))
+			  finally (return (dpb result (byte i 0) -1))))))
+	      `(signed-byte ,i)
+	      (/ i 8)))))
 
 ;;; Return a string constructed from SAP, START, and END.
 (defun string-from-sap (sap start end)
@@ -791,27 +883,40 @@
      (setf (fd-stream-unread fd-stream) arg1)
      (setf (fd-stream-listen fd-stream) t))
     (:close
-     (cond (arg1
-	    ;; We got us an abort on our hands.
+     (cond (arg1 ; We got us an abort on our hands.
 	    (when (fd-stream-handler fd-stream)
-		  (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
-		  (setf (fd-stream-handler fd-stream) nil))
+	      (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+	      (setf (fd-stream-handler fd-stream) nil))
+	    ;; We can't do anything unless we know what file were
+	    ;; dealing with, and we don't want to do anything
+	    ;; strange unless we were writing to the file.
 	    (when (and (fd-stream-file fd-stream)
 		       (fd-stream-obuf-sap fd-stream))
-	      ;; We can't do anything unless we know what file were
-	      ;; dealing with, and we don't want to do anything
-	      ;; strange unless we were writing to the file.
 	      (if (fd-stream-original fd-stream)
-		  ;; We have a handle on the original, just revert.
-		  (multiple-value-bind (okay err)
-		      (sb!unix:unix-rename (fd-stream-original fd-stream)
-					   (fd-stream-file fd-stream))
-		    (unless okay
-		      (simple-stream-perror
-		       "couldn't restore ~S to its original contents"
-		       fd-stream
-		       err)))
-		  ;; We can't restore the original, so nuke that puppy.
+		  ;; If the original is EQ to file we are appending
+		  ;; and can just close the file without renaming.
+		  (unless (eq (fd-stream-original fd-stream)
+			      (fd-stream-file fd-stream))
+		    ;; We have a handle on the original, just revert.
+		    (multiple-value-bind (okay err)
+			(sb!unix:unix-rename (fd-stream-original fd-stream)
+					     (fd-stream-file fd-stream))
+		      (unless okay
+			(simple-stream-perror
+			 "couldn't restore ~S to its original contents"
+			 fd-stream
+			 err))))
+		  ;; We can't restore the original, and aren't
+		  ;; appending, so nuke that puppy.
+		  ;;
+		  ;; FIXME: This is currently the fate of superseded
+		  ;; files, and according to the CLOSE spec this is
+		  ;; wrong. However, there seems to be no clean way to
+		  ;; do that that doesn't involve either copying the
+		  ;; data (bad if the :abort resulted from a full
+		  ;; disk), or renaming the old file temporarily
+		  ;; (probably bad because stream opening becomes more
+		  ;; racy).
 		  (multiple-value-bind (okay err)
 		      (sb!unix:unix-unlink (fd-stream-file fd-stream))
 		    (unless okay
@@ -1094,6 +1199,8 @@
    :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
   See the manual for details."
 
+  (declare (ignore external-format)) ; FIXME: CHECK-TYPE?  WARN-if-not?
+  
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)
       (case direction
@@ -1106,6 +1213,8 @@
 	   (namestring
 	    (cond ((unix-namestring pathname input))
 		  ((and input (eq if-does-not-exist :create))
+		   (unix-namestring pathname nil))
+		  ((and (eq direction :io) (not if-does-not-exist-given))
 		   (unix-namestring pathname nil)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
@@ -1147,12 +1256,16 @@
       (if (eq if-does-not-exist :create)
 	(setf mask (logior mask sb!unix:o_creat)))
 
-      (let ((original (if (member if-exists
-				  '(:rename :rename-and-delete))
-			  (pick-backup-name namestring)))
+      (let ((original (case if-exists
+			((:rename :rename-and-delete)
+			 (pick-backup-name namestring))
+			((:append)
+			 ;; KLUDGE: Provent CLOSE from deleting
+			 ;; appending streams when called with :ABORT T
+			 namestring)))
 	    (delete-original (eq if-exists :rename-and-delete))
 	    (mode #o666))
-	(when original
+	(when (and original (not (eq original namestring)))
 	  ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
 	  ;; whether the file already exists, make sure the original
 	  ;; file is not a directory, and keep the mode.