Skip to content
Snippets Groups Projects
Commit 70f497e1 authored by rtoy's avatar rtoy
Browse files

Enhance PICK-OUTPUT-ROUTINE and PICK-INPUT-ROUTINE to support byte

sizes up to MAX-STREAM-ELEMENT-SIZE (currently 1024).

Ported from SBCL, with minor changes.
parent 212e590f
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.78 2004/04/23 03:26:44 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.79 2004/04/23 15:08:15 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -43,6 +43,10 @@ ...@@ -43,6 +43,10 @@
(defconstant bytes-per-buffer (* 4 1024) (defconstant bytes-per-buffer (* 4 1024)
"Number of bytes per buffer.") "Number of bytes per buffer.")
;; This limit is rather arbitrary
(defconstant max-stream-element-size 1024
"The maximum supported byte size for a stream element-type.")
;;; NEXT-AVAILABLE-BUFFER -- Internal. ;;; NEXT-AVAILABLE-BUFFER -- Internal.
;;; ;;;
;;; Returns the next available buffer, creating one if necessary. ;;; Returns the next available buffer, creating one if necessary.
...@@ -449,6 +453,30 @@ ...@@ -449,6 +453,30 @@
(:none (:none
(do-output stream thing start end nil)))))) (do-output stream thing start end nil))))))
(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))))
;;; PICK-OUTPUT-ROUTINE -- internal ;;; PICK-OUTPUT-ROUTINE -- internal
;;; ;;;
;;; Find an output routine to use given the type and buffering. Return as ;;; Find an output routine to use given the type and buffering. Return as
...@@ -459,10 +487,57 @@ ...@@ -459,10 +487,57 @@
(dolist (entry *output-routines*) (dolist (entry *output-routines*)
(when (and (subtypep type (car entry)) (when (and (subtypep type (car entry))
(eq buffering (cadr entry))) (eq buffering (cadr entry)))
(return (values (symbol-function (caddr entry)) (return-from pick-output-routine
(car entry) (values (symbol-function (caddr entry))
(cadddr entry)))))) (car entry)
(cadddr entry)))))
;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
(loop for i from 40 by 8 to max-stream-element-size ; 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 max-stream-element-size ; 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. ;;;; Input routines and related noise.
...@@ -655,9 +730,45 @@ ...@@ -655,9 +730,45 @@
(defun pick-input-routine (type) (defun pick-input-routine (type)
(dolist (entry *input-routines*) (dolist (entry *input-routines*)
(when (subtypep type (car entry)) (when (subtypep type (car entry))
(return (values (symbol-function (cadr entry)) (return-from pick-input-routine
(car entry) (values (symbol-function (cadr entry))
(caddr 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 max-stream-element-size ; 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 max-stream-element-size ; 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)))))
;;; STRING-FROM-SAP -- internal ;;; STRING-FROM-SAP -- internal
;;; ;;;
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment