Skip to content
Snippets Groups Projects
Commit 568d452e authored by rtoy's avatar rtoy
Browse files

This removes some code duplication by moving bref, etc. (accessors for

simple-streams buffers) into LISP and removes them from simple-streams
(and from EXT).

Use boot-2007-11-1.lisp to bootstrap the necessary symbol changes.

Patch from Paul Foley.
parent 0af400e1
No related branches found
No related tags found
No related merge requests found
;; Bootstrap file for bref cleanup
(in-package "EXTENSIONS")
(without-package-locks
(dolist (symbol '(bref buffer-sap endian-swap-value vector-elt-width))
(unintern symbol)))
(in-package "KERNEL")
(without-package-locks
(export 'simple-stream-buffer)
(deftype simple-stream-buffer ()
'(or sys:system-area-pointer (simple-unboxed-array (*))))
)
...@@ -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/exports.lisp,v 1.261 2007/10/25 15:17:07 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.262 2007/11/05 15:25:03 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -615,8 +615,8 @@ ...@@ -615,8 +615,8 @@
"BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2"
"BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR"
"BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET"
"BOOLE-XOR" "BOTH-CASE-P" "BOUNDP" "BREAK" "BOOLE-XOR" "BOTH-CASE-P" "BOUNDP" "BREAK" "BREF"
"BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUFFER-COPY" "BUFFER-SAP"
"BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE"
"CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR"
"CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR"
...@@ -663,7 +663,7 @@ ...@@ -663,7 +663,7 @@
"ECASE" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECASE" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM"
"ECHO-STREAM-OUTPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM"
"ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME"
"END-OF-FILE" "ENDP" "ENOUGH-NAMESTRING" "END-OF-FILE" "ENDIAN-SWAP-VALUE" "ENDP" "ENOUGH-NAMESTRING"
"ENSURE-DIRECTORIES-EXIST" "EQ" "EQL" "EQUAL" "ENSURE-DIRECTORIES-EXIST" "EQ" "EQL" "EQUAL"
"EQUALP" "ERROR" "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP" "EQUALP" "ERROR" "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP"
"EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR" "FBOUNDP" "FCEILING" "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR" "FBOUNDP" "FCEILING"
...@@ -824,40 +824,40 @@ ...@@ -824,40 +824,40 @@
"UNUSE-PACKAGE" "UNWIND-PROTECT" "UPGRADED-ARRAY-ELEMENT-TYPE" "UNUSE-PACKAGE" "UNWIND-PROTECT" "UPGRADED-ARRAY-ELEMENT-TYPE"
"UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P" "UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P"
"USE-PACKAGE" "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "USE-PACKAGE" "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES"
"VALUES-LIST" "VARIABLE" "VECTOR" "VECTOR-POP" "VECTOR-PUSH" "VALUES-LIST" "VARIABLE" "VECTOR" "VECTOR-ELT-WIDTH" "VECTOR-POP" "VECTOR-PUSH"
"VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN"
"WILD-PATHNAME-P" "WITH-COMPILATION-UNIT" "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT"
"WITH-CONDITION-RESTARTS" "WITH-CONDITION-RESTARTS"
"WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING" "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING"
"WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING"
"WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART"
"WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR"
"WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING" "WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING"
"WRITE-SEQUENCE" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP" "WRITE-SEQUENCE" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP"
"ADD-METHOD" "ALLOCATE-INSTANCE" "CALL-METHOD" "ADD-METHOD" "ALLOCATE-INSTANCE" "CALL-METHOD"
"CALL-NEXT-METHOD" "CHANGE-CLASS" "CALL-NEXT-METHOD" "CHANGE-CLASS"
"COMPUTE-APPLICABLE-METHODS" "DEFCLASS" "DEFGENERIC" "COMPUTE-APPLICABLE-METHODS" "DEFCLASS" "DEFGENERIC"
"DEFINE-METHOD-COMBINATION" "DEFMETHOD" "DESCRIBE-OBJECT" "DEFINE-METHOD-COMBINATION" "DEFMETHOD" "DESCRIBE-OBJECT"
"ENSURE-GENERIC-FUNCTION" "ENSURE-GENERIC-FUNCTION"
"FIND-METHOD" "FUNCTION-KEYWORDS" "FIND-METHOD" "FUNCTION-KEYWORDS"
"INITIALIZE-INSTANCE" "INVALID-METHOD-ERROR" "INITIALIZE-INSTANCE" "INVALID-METHOD-ERROR"
"MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE" "MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE"
"METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "NEXT-METHOD-P" "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "NEXT-METHOD-P"
"NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT" "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT"
"REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE" "REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE"
"SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING"
"SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD"
"STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT"
"UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS"
"UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS" "WITH-SLOTS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS" "WITH-SLOTS"
"MAKE-METHOD" "UNBOUND-SLOT" "UNBOUND-SLOT-INSTANCE" "MAKE-METHOD" "UNBOUND-SLOT" "UNBOUND-SLOT-INSTANCE"
"CELL-ERROR-NAME" "CELL-ERROR-NAME"
"GET-SETF-EXPANSION" "STYLE-WARNING" "GET-SETF-EXPANSION" "STYLE-WARNING"
"PRINT-NOT-READABLE-OBJECT" "PRINT-NOT-READABLE-OBJECT"
"DEFINE-SETF-EXPANDER" "PRINT-NOT-READABLE" "METHOD" "DEFINE-SETF-EXPANDER" "PRINT-NOT-READABLE" "METHOD"
"METHOD-COMBINATION" "METHOD-COMBINATION"
"MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS")) "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS"))
(defpackage "EVAL" (defpackage "EVAL"
(:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*"
...@@ -2122,7 +2122,7 @@ ...@@ -2122,7 +2122,7 @@
"SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF" "SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF"
"STD-COMPUTE-CLASS-PRECEDENCE-LIST" "STD-COMPUTE-CLASS-PRECEDENCE-LIST"
"STREAMLIKE" "STRINGABLE" "STRINGLIKE" "STREAMLIKE" "SIMPLE-STREAM-BUFFER" "STRINGABLE" "STRINGLIKE"
"%INSTANCE-LENGTH" "%INSTANCE-LENGTH"
"%INSTANCE-REF" "%INSTANCE-SET" "%INSTANCE-REF" "%INSTANCE-SET"
"SYSTEM-AREA-CLEAR" "SYSTEM-AREA-CLEAR"
......
...@@ -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.84 2006/02/27 16:06:34 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.85 2007/11/05 15:25:03 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -59,6 +59,83 @@ ...@@ -59,6 +59,83 @@
(pop *available-buffers*) (pop *available-buffers*)
(allocate-system-memory bytes-per-buffer))) (allocate-system-memory bytes-per-buffer)))
(declaim (inline buffer-sap bref (setf bref) buffer-copy))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
(optimize (speed 3) (space 2) (debug 0) (safety 0)
;; Suppress the note about having to box up the return:
(ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
(if offset (sys:sap+ sap offset) sap)))
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(sys:sap-ref-8 (buffer-sap buffer) index))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
(type fixnum soff doff length))
(sys:without-gcing ;; is this necessary??
(kernel:system-area-copy (buffer-sap src) (* soff 8)
(buffer-sap dst) (* doff 8)
(* length 8))))
#-(or big-endian little-endian)
(eval-when (:compile-toplevel)
(push (c::backend-byte-order c::*target-backend*) *features*))
(defun vector-elt-width (vector)
;; Return octet-width of vector elements
(etypecase vector
;; (simple-array fixnum (*)) not supported
;; (simple-array base-char (*)) treated specially; don't call this
((simple-array bit (*)) 1)
((simple-array (unsigned-byte 2) (*)) 1)
((simple-array (unsigned-byte 4) (*)) 1)
((simple-array (signed-byte 8) (*)) 1)
((simple-array (unsigned-byte 8) (*)) 1)
((simple-array (signed-byte 16) (*)) 2)
((simple-array (unsigned-byte 16) (*)) 2)
((simple-array (signed-byte 32) (*)) 4)
((simple-array (unsigned-byte 32) (*)) 4)
((simple-array single-float (*)) 4)
((simple-array double-float (*)) 8)
((simple-array (complex single-float) (*)) 8)
((simple-array (complex double-float) (*)) 16)
#+long-float
((simple-array long-float (*)) 10)
#+long-float
((simple-array (complex long-float) (*)) 20)
#+double-double
((simple-array double-double-float (*)) 16)
#+double-double
((simple-array (complex double-double-float) (*)) 32)))
(defun endian-swap-value (vector endian-swap)
(case endian-swap
(:network-order #+big-endian 0
#+little-endian (1- (vector-elt-width vector)))
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
(:byte-64 7)
(:byte-128 15)
;; additions by Lynn Quam
(:machine-endian 0)
(:big-endian #+big-endian 0
#+little-endian (1- (vector-elt-width vector)))
(:little-endian #+big-endian (1- (vector-elt-width vector))
#+little-endian 0)
(otherwise endian-swap)))
;;;; The FD-STREAM structure. ;;;; The FD-STREAM structure.
......
...@@ -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/stream-vector-io.lisp,v 1.2 2005/03/30 15:46:59 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream-vector-io.lisp,v 1.3 2007/11/05 15:25:03 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -21,84 +21,12 @@ ...@@ -21,84 +21,12 @@
(declaim (start-block read-vector write-vector)) (declaim (start-block read-vector write-vector))
;; copied from pcl/simple-streams/internal.lisp
#-(or big-endian little-endian)
(eval-when (:compile-toplevel)
(push (c::backend-byte-order c::*backend*) *features*))
(defun vector-elt-width (vector)
;; Return octet-width of vector elements
(etypecase vector
;; (simple-array fixnum (*)) not supported
;; (simple-array base-char (*)) treated specially; don't call this
(string 1)
((simple-array bit (*)) 1)
((simple-array (unsigned-byte 2) (*)) 1)
((simple-array (unsigned-byte 4) (*)) 1)
((simple-array (signed-byte 8) (*)) 1)
((simple-array (unsigned-byte 8) (*)) 1)
((simple-array (signed-byte 16) (*)) 2)
((simple-array (unsigned-byte 16) (*)) 2)
((simple-array (signed-byte 32) (*)) 4)
((simple-array (unsigned-byte 32) (*)) 4)
((simple-array single-float (*)) 4)
((simple-array double-float (*)) 8)
((simple-array (complex single-float) (*)) 8)
((simple-array (complex double-float) (*)) 16)))
;;; I have extended the permitted values of ENDIAN-SWAP to include
;;; :MACHINE-ENDIAN, :BIG-ENDIAN and :LITTLE-ENDIAN, and describe the byte order
;;; in the stream.
;;; :NETWORK-ORDER and :BIG-ENDIAN are the same.
;;; :MACHINE-ENDIAN and :BYTE-8 are the same.
(defun endian-swap-value (vector endian-swap)
(case endian-swap
((:big-endian :network-order)
#+big-endian 0
#+little-endian (1- (vector-elt-width vector)))
(:little-endian
#+little-endian 0
#+big-endian (1- (vector-elt-width vector)))
(:machine-endian 0)
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
(:byte-64 7)
(:byte-128 15)
(otherwise endian-swap)))
(declaim (inline buffer-sap bref (setf bref)))
(deftype simple-stream-buffer ()
'(or sys:system-area-pointer (kernel:simple-unboxed-array (*))))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null)
offset)
(optimize (speed 3) (space 2) (debug 0) (safety 0)
;; Suppress the note about having to box up the return:
(ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
(if offset (sys:sap+ sap offset) sap)))
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(sys:sap-ref-8 (buffer-sap buffer) index))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
;;; ENDIAN SWAPPING ;;; ENDIAN SWAPPING
;;; Not sure that this is really need, but for completeness ... ;;; Not sure that this is really need, but for completeness ...
(defun swap-endians-456 (vector start end endian) (defun swap-endians-456 (vector start end endian)
(declare (optimize (speed 3)(safety 0))) (declare (optimize (speed 3)(safety 0)))
(declare (type simple-stream-buffer vector)) (declare (type kernel:simple-stream-buffer vector))
(declare (fixnum start end endian)) (declare (fixnum start end endian))
(loop for i fixnum from (* 8 start) below (* 8 end) by 8 (loop for i fixnum from (* 8 start) below (* 8 end) by 8
for b0 fixnum = (bref vector i) for b0 fixnum = (bref vector i)
...@@ -232,7 +160,3 @@ ...@@ -232,7 +160,3 @@
(declaim (end-block)) ; READ-VECTOR WRITE-VECTOR block (declaim (end-block)) ; READ-VECTOR WRITE-VECTOR block
...@@ -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/type.lisp,v 1.74 2006/07/18 18:31:38 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.75 2007/11/05 15:25:03 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -3564,6 +3564,10 @@ ...@@ -3564,6 +3564,10 @@
;;; A valid argument to a stream function... ;;; A valid argument to a stream function...
(deftype streamlike () '(or stream (member nil t))) (deftype streamlike () '(or stream (member nil t)))
;;; ;;;
;;; A stream buffer, for simple-streams and read/write-vector
(deftype simple-stream-buffer ()
'(or sys:system-area-pointer (simple-unboxed-array (*))))
;;;
;;; A thing that can be passed to funcall & friends. ;;; A thing that can be passed to funcall & friends.
(deftype callable () '(or function symbol)) (deftype callable () '(or function symbol))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; domain. ;;; domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.5 2005/10/06 13:49:26 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.6 2007/11/05 15:25:04 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -20,8 +20,8 @@ ...@@ -20,8 +20,8 @@
;;;; Types for buffer and strategy functions ;;;; Types for buffer and strategy functions
(deftype simple-stream-buffer () ;;(deftype simple-stream-buffer ()
'(or sys:system-area-pointer (kernel:simple-unboxed-array (*)))) ;; '(or sys:system-area-pointer (kernel:simple-unboxed-array (*))))
(deftype blocking () (deftype blocking ()
`(member t nil :bnb)) `(member t nil :bnb))
...@@ -80,7 +80,7 @@ ...@@ -80,7 +80,7 @@
:accessor stream-line-column) :accessor stream-line-column)
(record-end :initform nil :type (or null fixnum)) (record-end :initform nil :type (or null fixnum))
(buffer :initform nil :type (or simple-stream-buffer null)) (buffer :initform nil :type (or kernel:simple-stream-buffer null))
(buffpos :initform 0 :type fixnum) (buffpos :initform 0 :type fixnum)
(buffer-ptr :initform 0 :type fixnum) (buffer-ptr :initform 0 :type fixnum)
(buf-len :initform 0 :type fixnum) (buf-len :initform 0 :type fixnum)
...@@ -92,7 +92,7 @@ ...@@ -92,7 +92,7 @@
((mode :initform 0 :type fixnum))) ((mode :initform 0 :type fixnum)))
(def-stream-class dual-channel-simple-stream (simple-stream) (def-stream-class dual-channel-simple-stream (simple-stream)
((out-buffer :initform nil :type (or simple-stream-buffer null)) ((out-buffer :initform nil :type (or kernel:simple-stream-buffer null))
(outpos :initform 0 :type fixnum) (outpos :initform 0 :type fixnum)
(max-out-pos :initform 0 :type fixnum) (max-out-pos :initform 0 :type fixnum)
(mode :initform 0 :type fixnum))) (mode :initform 0 :type fixnum)))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; domain. ;;; domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.3 2007/11/05 15:25:04 rtoy Rel $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
()) ())
(def-stream-class buffer-output-simple-stream (direct-simple-stream) (def-stream-class buffer-output-simple-stream (direct-simple-stream)
((out-buffer :initform nil :type (or simple-stream-buffer null)) ((out-buffer :initform nil :type (or kernel:simple-stream-buffer null))
(outpos :initform 0 :type fixnum) (outpos :initform 0 :type fixnum)
(max-out-pos :initform 0 :type fixnum))) (max-out-pos :initform 0 :type fixnum)))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; domain. ;;; domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.6 2007/10/25 15:17:07 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.7 2007/11/05 15:25:04 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -13,35 +13,7 @@ ...@@ -13,35 +13,7 @@
(in-package "STREAM") (in-package "STREAM")
(declaim (inline buffer-sap bref (setf bref) buffer-copy (declaim (inline allocate-buffer free-buffer))
allocate-buffer free-buffer))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
(optimize (speed 3) (space 2) (debug 0) (safety 0)
;; Suppress the note about having to box up the return:
(ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
(if offset (sys:sap+ sap offset) sap)))
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(sys:sap-ref-8 (buffer-sap buffer) index))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
(type fixnum soff doff length))
(sys:without-gcing ;; is this necessary??
(kernel:system-area-copy (buffer-sap src) (* soff 8)
(buffer-sap dst) (* doff 8)
(* length 8))))
(defun allocate-buffer (size) (defun allocate-buffer (size)
(if (= size lisp::bytes-per-buffer) (if (= size lisp::bytes-per-buffer)
...@@ -89,41 +61,6 @@ ...@@ -89,41 +61,6 @@
#-(or big-endian little-endian)
(eval-when (:compile-toplevel)
(push (c::backend-byte-order c::*target-backend*) *features*))
(defun vector-elt-width (vector)
;; Return octet-width of vector elements
(etypecase vector
;; (simple-array fixnum (*)) not supported
;; (simple-array base-char (*)) treated specially; don't call this
((simple-array bit (*)) 1)
((simple-array (unsigned-byte 2) (*)) 1)
((simple-array (unsigned-byte 4) (*)) 1)
((simple-array (signed-byte 8) (*)) 1)
((simple-array (unsigned-byte 8) (*)) 1)
((simple-array (signed-byte 16) (*)) 2)
((simple-array (unsigned-byte 16) (*)) 2)
((simple-array (signed-byte 32) (*)) 4)
((simple-array (unsigned-byte 32) (*)) 4)
((simple-array single-float (*)) 4)
((simple-array double-float (*)) 8)
((simple-array (complex single-float) (*)) 8)
((simple-array (complex double-float) (*)) 16)))
(defun endian-swap-value (vector endian-swap)
(case endian-swap
(:network-order #+big-endian 0
#+little-endian (1- (vector-elt-width vector)))
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
(:byte-64 7)
(:byte-128 15)
(otherwise endian-swap)))
#+(or) #+(or)
(defun %read-vector (vector stream start end endian-swap blocking) (defun %read-vector (vector stream start end endian-swap blocking)
(declare (type (kernel:simple-unboxed-array (*)) vector) (declare (type (kernel:simple-unboxed-array (*)) vector)
...@@ -138,7 +75,7 @@ ...@@ -138,7 +75,7 @@
(defun read-octets (stream buffer start end blocking) (defun read-octets (stream buffer start end blocking)
(declare (type simple-stream stream) (declare (type simple-stream stream)
(type (or null simple-stream-buffer) buffer) (type (or null kernel:simple-stream-buffer) buffer)
(type fixnum start) (type fixnum start)
(type (or null fixnum) end) (type (or null fixnum) end)
(optimize (speed 3) (space 2) (safety 0) (debug 0))) (optimize (speed 3) (space 2) (safety 0) (debug 0)))
...@@ -196,7 +133,7 @@ ...@@ -196,7 +133,7 @@
(defun write-octets (stream buffer start end blocking) (defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream) (declare (type simple-stream stream)
(type simple-stream-buffer buffer) (type kernel:simple-stream-buffer buffer)
(type fixnum start) (type fixnum start)
(type (or null fixnum) end)) (type (or null fixnum) end))
(with-stream-class (simple-stream stream) (with-stream-class (simple-stream stream)
...@@ -250,7 +187,7 @@ ...@@ -250,7 +187,7 @@
(start (second list)) (start (second list))
(end (third list)) (end (third list))
(len (- end start))) (len (- end start)))
(declare (type simple-stream-buffer buffer) (declare (type kernel:simple-stream-buffer buffer)
(type lisp::index start end len)) (type lisp::index start end len))
(tagbody again (tagbody again
(multiple-value-bind (bytes errno) (multiple-value-bind (bytes errno)
...@@ -270,7 +207,7 @@ ...@@ -270,7 +207,7 @@
(defun queue-write (stream buffer start end) (defun queue-write (stream buffer start end)
;; Queue a write; return T if buffer needs changing, NIL otherwise ;; Queue a write; return T if buffer needs changing, NIL otherwise
(declare (type simple-stream stream) (declare (type simple-stream stream)
(type simple-stream-buffer buffer) (type kernel:simple-stream-buffer buffer)
(type lisp::index start end)) (type lisp::index start end))
(with-stream-class (simple-stream stream) (with-stream-class (simple-stream stream)
(when (sm handler stream) (when (sm handler stream)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; domain. ;;; domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.3 2003/06/26 13:27:43 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.4 2007/11/05 15:25:04 rtoy Rel $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
()) ())
(def-stream-class string-output-simple-stream (string-simple-stream) (def-stream-class string-output-simple-stream (string-simple-stream)
((out-buffer :initform nil :type (or simple-stream-buffer null)) ((out-buffer :initform nil :type (or kernel:simple-stream-buffer null))
(outpos :initform 0 :type fixnum) (outpos :initform 0 :type fixnum)
(max-out-pos :initform 0 :type fixnum))) (max-out-pos :initform 0 :type fixnum)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment