0.8.7.48:

	Allow opening of streams with element-type larger than 32 bits
	... autogenerate an input/output routine if it's none of our
		friendly predefined ones are applicable
	... arbitrary constants, endianness issues and the like are
		all wilfully ignored.
	... passes 12 more of PFD's ansi-tests!

diff --git a/NEWS b/NEWS
index df38115..564f221 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2298,6 +2298,8 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7:
        examining the synonym.
     ** STREAM-ELEMENT-TYPE and FRESH-LINE on broadcast-streams now
        work as specified.
+    ** OPEN and WITH-OPEN-STREAM allow opening streams with
+       element-type larger than ([UN]SIGNED-BYTE 32).
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 3c2f286..fe180be 100644 (file)
--- 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)))))
 \f
 ;;;; input routines and related noise
 
@@ -579,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)

diff --git a/version.lisp-expr b/version.lisp-expr
index a0d7411..29abb7d 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.7.47"
+"0.8.7.48"