/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Diff of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.84 by rtoy, Mon Feb 27 16:06:34 2006 UTC revision 1.85 by rtoy, Mon Nov 5 15:25:03 2007 UTC
# Line 59  Line 59 
59        (pop *available-buffers*)        (pop *available-buffers*)
60        (allocate-system-memory bytes-per-buffer)))        (allocate-system-memory bytes-per-buffer)))
61    
62    (declaim (inline buffer-sap bref (setf bref) buffer-copy))
63    
64    (defun buffer-sap (thing &optional offset)
65      (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
66               (optimize (speed 3) (space 2) (debug 0) (safety 0)
67                         ;; Suppress the note about having to box up the return:
68                         (ext:inhibit-warnings 3)))
69      (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
70        (if offset (sys:sap+ sap offset) sap)))
71    
72    (defun bref (buffer index)
73      (declare (type simple-stream-buffer buffer)
74               (type (integer 0 #.most-positive-fixnum) index))
75      (sys:sap-ref-8 (buffer-sap buffer) index))
76    
77    (defun (setf bref) (octet buffer index)
78      (declare (type (unsigned-byte 8) octet)
79               (type simple-stream-buffer buffer)
80               (type (integer 0 #.most-positive-fixnum) index))
81      (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
82    
83    (defun buffer-copy (src soff dst doff length)
84      (declare (type simple-stream-buffer src dst)
85               (type fixnum soff doff length))
86      (sys:without-gcing ;; is this necessary??
87       (kernel:system-area-copy (buffer-sap src) (* soff 8)
88                                (buffer-sap dst) (* doff 8)
89                                (* length 8))))
90    
91    #-(or big-endian little-endian)
92    (eval-when (:compile-toplevel)
93      (push (c::backend-byte-order c::*target-backend*) *features*))
94    
95    (defun vector-elt-width (vector)
96      ;; Return octet-width of vector elements
97      (etypecase vector
98        ;; (simple-array fixnum (*)) not supported
99        ;; (simple-array base-char (*)) treated specially; don't call this
100        ((simple-array bit (*)) 1)
101        ((simple-array (unsigned-byte 2) (*)) 1)
102        ((simple-array (unsigned-byte 4) (*)) 1)
103        ((simple-array (signed-byte 8) (*)) 1)
104        ((simple-array (unsigned-byte 8) (*)) 1)
105        ((simple-array (signed-byte 16) (*)) 2)
106        ((simple-array (unsigned-byte 16) (*)) 2)
107        ((simple-array (signed-byte 32) (*)) 4)
108        ((simple-array (unsigned-byte 32) (*)) 4)
109        ((simple-array single-float (*)) 4)
110        ((simple-array double-float (*)) 8)
111        ((simple-array (complex single-float) (*)) 8)
112        ((simple-array (complex double-float) (*)) 16)
113        #+long-float
114        ((simple-array long-float (*)) 10)
115        #+long-float
116        ((simple-array (complex long-float) (*)) 20)
117        #+double-double
118        ((simple-array double-double-float (*)) 16)
119        #+double-double
120        ((simple-array (complex double-double-float) (*)) 32)))
121    
122    (defun endian-swap-value (vector endian-swap)
123      (case endian-swap
124        (:network-order #+big-endian 0
125                        #+little-endian (1- (vector-elt-width vector)))
126        (:byte-8 0)
127        (:byte-16 1)
128        (:byte-32 3)
129        (:byte-64 7)
130        (:byte-128 15)
131        ;; additions by Lynn Quam
132        (:machine-endian 0)
133        (:big-endian #+big-endian 0
134                     #+little-endian (1- (vector-elt-width vector)))
135        (:little-endian #+big-endian (1- (vector-elt-width vector))
136                        #+little-endian 0)
137        (otherwise endian-swap)))
138    
139    
140  ;;;; The FD-STREAM structure.  ;;;; The FD-STREAM structure.
141    

Legend:
Removed from v.1.84  
changed lines
  Added in v.1.85

  ViewVC Help
Powered by ViewVC 1.1.5