/usr/share/gauche-0.9/0.9.1/lib/binary/io.scm is in gauche 0.9.1-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | ;;;; binary.io -- serializing binary data
;;; Created: <2003-01-20 23:25:06 foof>
;;; Time-stamp: <2003-01-29 20:53:45 foof>
;;; Author: Alex Shinn <foof@synthcode.com>
;; It is computed that eleven thousand persons have at several times
;; suffered death, rather than submit to break their eggs at the smaller
;; end. Many hundred large volumes have been published upon this
;; controversy: but the books of the Big-endians have been long
;; forbidden, and the whole party rendered incapable by law of holding
;; employments.
;; -- from "Gulliver's Travels" by Jonathan Swift
;; [SK]:
;;
(define-module binary.io
(use gauche.uvector)
(use srfi-1) ;; list library
(use srfi-13) ;; string library
(export read-uint read-u8 read-u16 read-u32 read-u64
read-sint read-s8 read-s16 read-s32 read-s64
read-ber-integer read-f16 read-f32 read-f64
write-uint write-u8 write-u16 write-u32 write-u64
write-sint write-s8 write-s16 write-s32 write-s64
write-ber-integer write-f16 write-f32 write-f64
get-u8 get-u16 get-u32 get-u64 get-s8 get-s16 get-s32 get-s64
get-f16 get-f32 get-f64
get-u16be get-u16le get-u32be get-u32le get-u64be get-u64le
get-s16be get-s16le get-s32be get-s32le get-s64be get-s64le
get-f16be get-f16le get-f32be get-f32le get-f64be get-f64le
put-u8! put-u16! put-u32! put-u64! put-s8! put-s16! put-s32! put-s64!
put-f16! put-f32! put-f64!
put-u16be! put-u16le! put-u32be! put-u32le! put-u64be! put-u64le!
put-s16be! put-s16le! put-s32be! put-s32le! put-s64be! put-s64le!
put-f16be! put-f16le! put-f32be! put-f32le! put-f64be! put-f64le!
;; old names
read-binary-uint
read-binary-uint8 read-binary-uint16
read-binary-uint32 read-binary-uint64
read-binary-sint
read-binary-sint8 read-binary-sint16
read-binary-sint32 read-binary-sint64
read-binary-short read-binary-ushort
read-binary-long read-binary-ulong
read-binary-float read-binary-double
write-binary-uint
write-binary-uint8 write-binary-uint16
write-binary-uint32 write-binary-uint64
write-binary-sint
write-binary-sint8 write-binary-sint16
write-binary-sint32 write-binary-sint64
write-binary-short write-binary-ushort
write-binary-long write-binary-ulong
write-binary-float write-binary-double
))
(select-module binary.io)
(dynamic-load "binary--io")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; config
(define-constant *bit-size* 2) ;; hey, you never know :)
(define-constant *byte-size* 8)
(define-constant *byte-magnitude* (expt *bit-size* *byte-size*))
(define-constant *byte-mask* (- *byte-magnitude* 1))
(define-constant *byte-right-shift* (* -1 *byte-size*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic reading
;; mind-numblingly slow, consider a uvector approach but it doesn't
;; handle endianess
(define (read-uint size :optional (port (current-input-port))
(endian (default-endian)))
(case size
[(1) (read-u8 port endian)]
[(2) (read-u16 port endian)]
[(4) (read-u32 port endian)]
[(8) (read-u64 port endian)]
[else
(let loop ((ls '())
(cnt 0))
(if (= cnt size)
(fold (lambda (a b) (+ a (* b *byte-magnitude*)))
0
(if (eq? endian 'big-endian) (reverse ls) ls))
(let1 byte (read-byte port)
(if (eof-object? byte)
byte
(loop (cons byte ls) (+ cnt 1))))))]
))
(define (lognot-small int bytes)
(logand (lognot int) (- (expt *bit-size* (* *byte-size* bytes)) 1)))
(define (uint->sint int bytes)
(let ((highbit (- (* *byte-size* bytes) 1)))
(if (logbit? highbit int)
(* -1 (+ 1 (lognot-small int bytes)))
int)))
(define (sint->uint int bytes)
(if (< int 0)
(+ 1 (lognot-small (abs int) bytes))
int))
(define (read-sint size :optional
(port (current-input-port))
(endian (default-endian)))
(case size
[(1) (read-s8 port endian)]
[(2) (read-s16 port endian)]
[(4) (read-s32 port endian)]
[(8) (read-s64 port endian)]
[else (uint->sint (read-uint size port endian) size)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic writing
(define (write-uint size int :optional
(port (current-output-port))
(endian (default-endian)))
(case size
[(1) (write-u8 int port endian)]
[(2) (write-u16 int port endian)]
[(4) (write-u32 int port endian)]
[(8) (write-u64 int port endian)]
[else
(let ((ls '()))
;; build a list of bytes
(dotimes (i size)
(push! ls (logand int *byte-mask*))
(set! int (ash int *byte-right-shift*)))
;; reverse if big-endian
(unless (eq? endian 'big-endian)
(set! ls (reverse ls)))
;; write the list
(for-each (cut write-byte <> port) ls))]))
(define (write-sint size int :optional
(port (current-output-port))
(endian (default-endian)))
(case size
[(1) (write-s8 int port endian)]
[(2) (write-s16 int port endian)]
[(4) (write-s32 int port endian)]
[(8) (write-s64 int port endian)]
[else (write-uint size (sint->uint int size) port endian)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility
;;
;; These are used in binary.pack for the (unofficial) features to
;; read/write integers in "native" width of C system on the platform.
;; Should be removed soon (after binary.pack rewrite). Do not use them.
(define read-binary-short read-s16)
(define read-binary-ushort read-u16)
(define read-binary-long read-s32)
(define read-binary-ulong read-u32)
(define write-binary-short write-s16)
(define write-binary-ushort write-u16)
(define write-binary-long write-s32)
(define write-binary-ulong write-u32)
;; Other compatibility names. They have been official befor 0.8.10,
;; and used widely. So we keep them for a while.
(define read-binary-uint read-uint)
(define read-binary-sint read-sint)
(define read-binary-uint8 read-u8)
(define read-binary-sint8 read-s8)
(define read-binary-uint16 read-u16)
(define read-binary-sint16 read-s16)
(define read-binary-uint32 read-u32)
(define read-binary-sint32 read-s32)
(define read-binary-uint64 read-u64)
(define read-binary-sint64 read-s64)
(define read-binary-float read-f32)
(define read-binary-double read-f64)
(define write-binary-uint write-uint)
(define write-binary-sint write-sint)
(define write-binary-uint8 write-u8)
(define write-binary-sint8 write-s8)
(define write-binary-uint16 write-u16)
(define write-binary-sint16 write-s16)
(define write-binary-uint32 write-u32)
(define write-binary-sint32 write-s32)
(define write-binary-uint64 write-u64)
(define write-binary-sint64 write-s64)
(define write-binary-float write-f32)
(define write-binary-double write-f64)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bignum encodings -- Basic Encoding Rules (BER) from X.209
;; A BER compressed integer is an unsigned integer in base 128, most
;; significant digit first, where the high bit is set on all but the
;; final (least significant) byte. Thus any size integer can be
;; encoded, but the encoding is efficient and small integers don't take
;; up any more space than they would in normal char/short/int encodings.
(define (read-ber-integer :optional (port (current-input-port)))
(let1 first (read-byte port)
(if (eof-object? first)
first ;; stop on eof
(if (< first 128)
first
(let loop ((res (ash (logand first #b01111111) 7))
(byte (read-u8 port)))
(if (< byte 128)
(+ res byte) ;; final byte
(loop (ash (+ res (logand byte #b01111111)) 7)
(read-u8 port))))))))
(define (write-ber-integer number :optional (port (current-output-port)))
(let ((final (logand number #b01111111))
(start (ash number -7)))
(unless (zero? start)
(let loop ((n start))
(cond [(< n 128) (write-u8 (logior n #b10000000))]
[else
(loop (ash n -7)) ;; write high bytes first
(write-u8 (logior (logand n #b01111111) #b10000000))])))
(write-u8 final)))
|