From 1d8df49a27fcdccbab5037d83b98a56889cb0b59 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 9 Jul 2004 21:54:30 +0000
Subject: [PATCH] o Add support for read-sequence and write-sequence for byte
 sequences   for simple-streams. o Initial support for memory-mapped files for
 simple-streams.

(Ported from sbcl's simple-stream implementation.)
---
 pcl/simple-streams/impl.lisp     |  89 ++++++++++++++++++------
 pcl/simple-streams/strategy.lisp | 116 ++++++++++++++++++++++++++++++-
 2 files changed, 181 insertions(+), 24 deletions(-)

diff --git a/pcl/simple-streams/impl.lisp b/pcl/simple-streams/impl.lisp
index 7d3a0c556..dd6a45d6b 100644
--- a/pcl/simple-streams/impl.lisp
+++ b/pcl/simple-streams/impl.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.4 2003/06/26 13:27:43 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.5 2004/07/09 21:54:30 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -397,7 +397,8 @@
   (declare (type simple-stream stream))
   (%check stream :output)
   ;; implement me
-  )
+  nil)
+
 
 (defun %finish-output (stream)
   (declare (type simple-stream stream))
@@ -493,6 +494,9 @@
     (%check stream :input)
     (when (any-stream-instance-flags stream :eof)
       (return-from %read-sequence 0))
+    (when (and (not (any-stream-instance-flags stream :dual :string))
+               (sc-dirty-p stream))
+      (flush-buffer stream t))
     (etypecase seq
       (string
        (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
@@ -500,9 +504,17 @@
 			    (if partial-fill :bnb t)))
       ((or (simple-array (unsigned-byte 8) (*))
 	   (simple-array (signed-byte 8) (*)))
+       (when (any-stream-instance-flags stream :string)
+         (error "Can't read into byte sequence from a string stream."))       
        ;; "read-vector" equivalent, but blocking if partial-fill is NIL
-       (error "implement me")
-       )
+       ;; FIXME: this could be implemented faster via buffer-copy
+       (loop with encap = (sm melded-stream stream)
+            for index from start below (or end (length seq))
+            for byte = (read-byte-internal encap nil nil t)
+              then (read-byte-internal encap nil nil partial-fill)
+            while byte
+            do (setf (bref seq index) byte)
+            finally (return index)))
       ;; extend to work on other sequences: repeated read-byte
       )))
 
@@ -520,28 +532,64 @@
       ((or (simple-array (unsigned-byte 8) (*))
 	   (simple-array (signed-byte 8) (*)))
        ;; "write-vector" equivalent
-       (error "implement me")
+       (setf (sm charpos stream) nil)
+       (simple-stream-dispatch stream
+         ;; single-channel-simple-stream
+         (with-stream-class (single-channel-simple-stream stream)
+            (loop with max-ptr fixnum = (sm buf-len stream)
+                  for src-pos fixnum = start then (+ src-pos count)
+                  for src-rest fixnum = (- (or end (length seq)) src-pos)
+                  while (> src-rest 0) ; FIXME: this is non-ANSI
+                  for ptr fixnum = (let ((ptr (sm buffpos stream)))
+                                     (if (>= ptr max-ptr)
+                                         (flush-buffer stream t)
+                                         ptr))
+                  for buf-rest fixnum = (- max-ptr ptr)
+                  for count fixnum = (min buf-rest src-rest)
+                  do (progn (setf (sm mode stream) 1)
+                            (setf (sm buffpos stream) (+ ptr count))
+                            (buffer-copy seq src-pos (sm buffer stream) ptr count))))
+         ;; dual-channel-simple-stream
+         (with-stream-class (dual-channel-simple-stream stream)
+            (loop with max-ptr fixnum = (sm max-out-pos stream)
+                  for src-pos fixnum = start then (+ src-pos count)
+                  for src-rest fixnum = (- (or end (length seq)) src-pos)
+                  while (> src-rest 0) ; FIXME: this is non-ANSI
+                  for ptr fixnum = (let ((ptr (sm outpos stream)))
+                                     (if (>= ptr max-ptr)
+                                         (flush-out-buffer stream t)
+                                         ptr))
+                  for buf-rest fixnum = (- max-ptr ptr)
+                  for count fixnum = (min buf-rest src-rest)
+                  do (progn (setf (sm outpos stream) (+ ptr count))
+                            (buffer-copy seq src-pos (sm out-buffer stream) ptr count))))
+         ;; string-simple-stream
+         (error 'simple-type-error
+                 :datum stream
+                 :expected-type 'stream
+                 :format-control "Can't write a byte sequence to a string stream."
+                 :format-arguments '()))
        )
       ;; extend to work on other sequences: repeated write-byte
-      )))
-
+      ))
+  seq)
 
 (defun read-no-hang-p (stream)
   (declare (type (or integer stream) stream))
   (etypecase stream
     (integer (sys:wait-until-fd-usable stream :input 0))
     (simple-stream (%check stream :input)
-		   (when (any-stream-instance-flags stream :eof)
-		     (return-from read-no-hang-p nil))
-		   (simple-stream-dispatch stream
-		     ;; single-channel-simple-stream
-		     nil
-		     ;; dual-channel-simple-stream
-		     ;; if record-end is -1, call device-finish-record
-		     ;; return NIL if it returns NIL, T if it returns :EOF
-		     nil
-		     ;; string-simple-stream
-		     nil))
+                   (when (any-stream-instance-flags stream :eof)
+                     (return-from read-no-hang-p nil))
+                   (simple-stream-dispatch stream
+                     ;; single-channel-simple-stream
+                     nil
+                     ;; dual-channel-simple-stream
+                     ;; if record-end is -1, call device-finish-record
+                     ;; return NIL if it returns NIL, T if it returns :EOF
+                     nil
+                     ;; string-simple-stream
+                     nil))
     (stream (listen stream))))
 
 (defun write-no-hang-p (stream)
@@ -551,7 +599,6 @@
     (simple-stream #| ... |#)
     (stream #| ... |#)))
 
-
 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
   (declare (type (kernel:simple-unboxed-array (*)) vector)
 	   (type stream stream))
@@ -585,7 +632,5 @@
      (unless (typep vector '(or string
 			     (simple-array (signed-byte 8) (*))
 			     (simple-array (unsigned-byte 8) (*))))
-       (error "Bad vector."))
+       (error "Wrong vector type for read-vector on stream not of type simple-stream."))
      (read-sequence vector stream :start (or start 0) :end end))))
-
-#|(defun write-vector ...)|#
diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp
index 734871f38..e9ca48b8b 100644
--- a/pcl/simple-streams/strategy.lisp
+++ b/pcl/simple-streams/strategy.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.6 2003/07/19 15:32:58 emarsden Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.7 2004/07/09 21:54:30 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -58,13 +58,30 @@
                                          unread))
         bytes))))
 
+(defun sc-set-dirty (stream)
+  (with-stream-class (single-channel-simple-stream stream)
+    (setf (sm mode stream)
+          (if (<= (sm buffpos stream)
+                  (sm buffer-ptr stream))
+              3    ; read-modify
+              1    ; write
+              ))))
+
+(defun sc-set-clean (stream)
+  (with-stream-class (single-channel-simple-stream stream)
+    (setf (sm mode stream) 0)))
+
+(defun sc-dirty-p (stream)
+  (with-stream-class (single-channel-simple-stream stream)
+    (> (sm mode stream) 0)))
+
 (defun flush-buffer (stream blocking)
   (with-stream-class (single-channel-simple-stream stream)
     (let ((ptr 0)
           (bytes (sm buffpos stream)))
       (declare (type fixnum ptr bytes))
       (loop
-        (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return 0))
+        (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0))
         (let ((bytes-written (device-write stream nil ptr nil blocking)))
           (declare (fixnum bytes-written))
           (when (minusp bytes-written)
@@ -170,6 +187,39 @@
 	      (lisp::eof-or-lose stream eof-error-p eof-value)
 	      char))))))
 
+
+(declaim (ftype j-read-char-fn (sc read-char :ef mapped)))
+(defun (sc read-char :ef mapped) (stream eof-error-p eof-value blocking)
+  #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
+  (declare (ignore blocking))
+  (with-stream-class (simple-stream stream)
+    (let* ((buffer (sm buffer stream))
+	   (buffpos (sm buffpos stream))
+	   (ctrl (sm control-in stream))
+	   (ef (sm external-format stream))
+	   (state (sm oc-state stream)))
+      (flet ((input ()
+	       (when (>= buffpos (sm buffer-ptr stream))
+		 (return-from read-char
+                   (lisp::eof-or-lose stream eof-error-p eof-value)))
+	       (incf (sm last-char-read-size stream))
+	       (prog1 (bref buffer buffpos)
+		 (incf buffpos)))
+	     (unput (n)
+	       (decf buffpos n)))
+	(let* ((cnt 0)
+	       (char (octets-to-char ef state cnt #'input #'unput))
+	       (code (char-code char)))
+	  (setf (sm buffpos stream) buffpos
+		(sm last-char-read-size stream) cnt
+		(sm oc-state stream) state)
+	  (when (and (< code 32) ctrl (svref ctrl code))
+	    (setq char (funcall (the (or symbol function) (svref ctrl code))
+				stream char)))
+	  (if (null char)
+	      (lisp::eof-or-lose stream eof-error-p eof-value)
+	      char))))))
+
 (declaim (ftype j-read-chars-fn (sc read-chars :ef)))
 (defun (sc read-chars :ef) (stream string search start end blocking)
   ;; string is filled from START to END, or until SEARCH is found
@@ -239,6 +289,67 @@
 		(t
 		 (setf (char string posn) char))))))))
 
+
+(declaim (ftype j-read-chars-fn (sc read-chars :ef mapped)))
+(defun (sc read-chars :ef mapped) (stream string search start end blocking)
+  ;; string is filled from START to END, or until SEARCH is found
+  ;; Return two values: count of chars read and
+  ;;  NIL if SEARCH was not found
+  ;;  T if SEARCH was found
+  ;;  :EOF if eof encountered before end
+  (declare (type simple-stream stream)
+           (type string string)
+           (type (or null character) search)
+           (type fixnum start end)
+           (type boolean blocking)
+           (ignore blocking)
+	   #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+  (with-stream-class (simple-stream stream)
+    ;; if stream is single-channel and mode == 3, flush buffer (if dirty)
+    (do ((buffer (sm buffer stream))
+         (buffpos (sm buffpos stream))
+         (buffer-ptr (sm buffer-ptr stream))
+	 (lcrs 0)
+	 (ctrl (sm control-in stream))
+	 (ef (sm external-format stream))
+	 (state (sm oc-state stream))
+         (posn start (1+ posn))
+         (count 0 (1+ count)))
+        ((>= posn end)
+	 (setf (sm buffpos stream) buffpos
+	       (sm last-char-read-size stream) lcrs
+	       (sm oc-state stream) state)
+	 (values count nil))
+      (declare (type lisp::index buffpos buffer-ptr posn count))
+      (flet ((input ()
+	       (when (>= buffpos buffer-ptr)
+                 (return (values count :eof)))
+	       (prog1 (bref buffer buffpos)
+		 (incf buffpos)
+		 (incf lcrs)))
+	     (unput (n)
+	       (decf buffpos n)))
+	(let* ((cnt 0)
+	       (char (octets-to-char ef state cnt #'input #'unput))
+	       (code (char-code char)))
+	  (setq lcrs cnt)
+	  (when (and (< code 32) ctrl (svref ctrl code))
+	    (setq char (funcall (the (or symbol function) (svref ctrl code))
+				stream char)))
+	  (cond ((null char)
+		 (setf (sm buffpos stream) buffpos
+		       (sm last-char-read-size stream) lcrs
+		       (sm oc-state stream) state)
+		 (return (values count :eof)))
+		((and search (char= char search))
+		 (setf (sm buffpos stream) buffpos
+		       (sm last-char-read-size stream) lcrs
+		       (sm oc-state stream) state)
+		 (return (values count t)))
+		(t
+		 (setf (char string posn) char))))))))
+
+
 (declaim (ftype j-unread-char-fn (sc unread-char :ef)))
 (defun (sc unread-char :ef) (stream relaxed)
   (declare (ignore relaxed))
@@ -470,6 +581,7 @@
 (defun %sf (kind name format &optional access)
   (or (ignore-errors (fdefinition (list kind name format access)))
       (ignore-errors (fdefinition (list kind name format)))
+      (ignore-errors (fdefinition (list kind name :ef access)))
       (fdefinition (list kind name :ef))))
 
 (defun install-single-channel-character-strategy (stream external-format
-- 
GitLab