X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=fe180be124b9a5e37290ddff78c40a33a9c94a45;hb=b3f188843330c56bd4d17a3c930e73f573b1c71f;hp=95b7ce215481f7c62a61dbb6b75180a3421a016f;hpb=02abc70f6d8d522d0b1b94a5eababda9409d1e53;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 95b7ce2..fe180be 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,22 +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)))
-		     ,@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
@@ -305,6 +315,9 @@
   (let ((start (or start 0))
 	(end (or end (length (the (simple-array * (*)) thing)))))
     (declare (type index start end))
+    (when (> (fd-stream-ibuf-tail fd-stream)
+	     (fd-stream-ibuf-head fd-stream))
+      (file-position fd-stream (file-position fd-stream)))
     (let* ((len (fd-stream-obuf-length fd-stream))
 	   (tail (fd-stream-obuf-tail fd-stream))
 	   (space (- len tail))
@@ -403,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
 
@@ -571,9 +635,44 @@
 (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)
+		(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)
@@ -591,12 +690,28 @@
 ;;; Note that this blocks in UNIX-READ. It is generally used where
 ;;; there is a definite amount of reading to be done, so blocking
 ;;; isn't too problematical.
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
+			       &aux (total-copied 0))
   (declare (type file-stream stream))
-  (declare (type index start requested))
-  (do ((total-copied 0))
+  (declare (type index start requested total-copied))
+  (let ((unread (fd-stream-unread stream)))
+    (when unread
+      ;; AVERs designed to fail when we have more complicated
+      ;; character representations.
+      (aver (typep unread 'base-char))
+      (aver (= (fd-stream-element-size stream) 1))
+      ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
+      ;; %BYTE-BLT
+      (etypecase buffer
+	(system-area-pointer
+	 (setf (sap-ref-8 buffer start) (char-code unread)))
+	((simple-unboxed-array (*))
+	 (setf (aref buffer start) unread)))
+      (setf (fd-stream-unread stream) nil)
+      (setf (fd-stream-listen stream) nil)
+      (incf total-copied)))
+  (do ()
       (nil)
-    (declare (type index total-copied))
     (let* ((remaining-request (- requested total-copied))
 	   (head (fd-stream-ibuf-head stream))
 	   (tail (fd-stream-ibuf-tail stream))
@@ -855,7 +970,6 @@
     (:element-type
      (fd-stream-element-type fd-stream))
     (:interactive-p
-      ;; FIXME: sb!unix:unix-isatty is undefined.
      (= 1 (the (member 0 1)
             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
     (:line-length
@@ -1083,6 +1197,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
@@ -1097,11 +1213,11 @@
 				     :append :supersede nil)
 			    :if-exists)
 	     (case if-exists
-	       ((:error nil)
+	       ((:new-version :error nil)
 		(setf mask (logior mask sb!unix:o_excl)))
 	       ((:rename :rename-and-delete)
 		(setf mask (logior mask sb!unix:o_creat)))
-	       ((:new-version :supersede)
+	       ((:supersede)
 		(setf mask (logior mask sb!unix:o_trunc)))
 	       (:append
 		(setf mask (logior mask sb!unix:o_append)))))
@@ -1210,7 +1326,7 @@
 		      (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
 				  pathname))
 		     (t nil)))
-		  ((and (eql errno sb!unix:eexist) if-exists)
+		  ((and (eql errno sb!unix:eexist) (null if-exists))
 		   nil)
 		  (t
 		   (vanilla-open-error)))))))))