80 lines
2.8 KiB
Scheme
80 lines
2.8 KiB
Scheme
; taken and adapted from Oleg Kiselyov's tiff-prober.scm
|
|
; Changes
|
|
; ##fixnumm.logior --> bitwise-ior
|
|
; ##fixnum.shl --> arithmetic-shift
|
|
; make-endian-port : switches off buffering
|
|
; To be evaluated in an environment binding
|
|
; DEFINE-STRUCTURE to the required syntax (like CL's DEFSTRUCT)
|
|
; CHAR->INTEGER to CHAR->ASCII
|
|
|
|
(define-structure endian-port port msb-first?)
|
|
(set! make-endian-port
|
|
(let ((really-make-endian-port make-endian-port))
|
|
(lambda (port msb-first?)
|
|
(set-port-buffering port bufpol/none) ; work around SEEK bug
|
|
(really-make-endian-port port msb-first?))))
|
|
|
|
(define (close-endian-port eport)
|
|
(close-input-port (endian-port-port eport)))
|
|
|
|
; endian-port-set-bigendian! EPORT -> UNSPECIFIED
|
|
(define (endian-port-set-bigendian! eport)
|
|
(endian-port-msb-first?-set! eport #t))
|
|
|
|
; endian-port-set-littlendian! EPORT -> UNSPECIFIED
|
|
(define (endian-port-set-littlendian! eport)
|
|
(endian-port-msb-first?-set! eport #f))
|
|
|
|
; endian-port-read-int1:: PORT -> UINTEGER (byte)
|
|
(define (endian-port-read-int1 eport)
|
|
(let ((c (read-char (endian-port-port eport))))
|
|
(if (eof-object? c) (error "unexpected EOF")
|
|
(char->integer c)))) ; Gambit-specific. Need read-byte
|
|
; sunterlib: c->i bound to char->ascii
|
|
|
|
; endian-port-read-int2:: PORT -> UINTEGER
|
|
(define (endian-port-read-int2 eport)
|
|
(let* ((c1 (endian-port-read-int1 eport))
|
|
(c2 (endian-port-read-int1 eport)))
|
|
(if (endian-port-msb-first? eport)
|
|
(bitwise-ior (arithmetic-shift c1 8) c2) ;(+ (* c1 256) c2)
|
|
(bitwise-ior (arithmetic-shift c2 8) c1) ;(+ (* c2 256) c1)
|
|
)))
|
|
|
|
; endian-port-read-int4:: PORT -> UINTEGER
|
|
(define (endian-port-read-int4 eport)
|
|
(let* ((c1 (endian-port-read-int1 eport))
|
|
(c2 (endian-port-read-int1 eport))
|
|
(c3 (endian-port-read-int1 eport))
|
|
(c4 (endian-port-read-int1 eport)))
|
|
(if (endian-port-msb-first? eport)
|
|
;; (+ c4 (* 256 (+ c3 (* 256 (+ c2 (* 256 c1))))))
|
|
(if (< c1 64) ; The int4 will fit into a fixnum
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior (arithmetic-shift c1 8) c2) 8) c3) 8) c4)
|
|
(+ (* 256 ; The multiplication will make a bignum
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior (arithmetic-shift c1 8) c2) 8) c3))
|
|
c4))
|
|
;; (+ c1 (* 256 (+ c2 (* 256 (+ c3 (* 256 c4))))))
|
|
; c4 is the most-significant byte
|
|
(if (< c4 64)
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior (arithmetic-shift c4 8) c3) 8) c2) 8) c1)
|
|
(+ (* 256
|
|
(bitwise-ior
|
|
(arithmetic-shift
|
|
(bitwise-ior (arithmetic-shift c4 8) c3) 8) c2))
|
|
c1)))))
|
|
|
|
; endian-port-setpos PORT INTEGER -> UNSPECIFIED
|
|
(define (endian-port-setpos eport pos)
|
|
(OS:fseek-abs (endian-port-port eport) pos))
|