lassik
/
scheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add peek library

This commit is contained in:
Lassi Kortela 2021-09-29 19:20:34 +03:00
parent ede11d4ba5
commit 118dd55027
1 changed files with 150 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
peek.sld Normal file
View File

@ -0,0 +1,150 @@
;;; Interactively examine binary files from a Scheme REPL.
(define-library (lassik peek)
(export peek-open
peek-port
origin
peek
peek*)
(import (scheme base) (scheme file))
(cond-expand
(gambit
(import (only (gambit)
input-port-byte-position
bitwise-ior
arithmetic-shift))))
(begin
(define peek-port (make-parameter #f))
(define origin (make-parameter 0))
(define (peek-open filename)
(let ((old-port (peek-port)))
(when old-port
(close-input-port old-port)))
(origin 0)
(peek-port #f)
(let ((new-port (open-binary-input-file filename)))
(peek-port new-port)
new-port))
(define-syntax abs
(syntax-rules ()
((abs n expr)
(parameterize ((origin n))
expr))))
(define-syntax rel
(syntax-rules ()
((rel n expr)
(parameterize ((origin (+ n (origin))))
expr))))
(define (peek-exactly-n-bytes n)
(let ((port (peek-port)))
(input-port-byte-position port (origin))
(let ((bytes (read-bytevector n port)))
(if (= n (bytevector-length bytes))
bytes
(error "How?")))))
(define (peek-bytevectors count n-byte)
(let ((vector (make-vector count #f)))
(let loop ((i 0))
(if (= i count) (vector->list vector)
(begin (vector-set! vector i
(parameterize ((origin (+ (origin)
(* i n-byte))))
(peek-exactly-n-bytes n-byte)))
(loop (+ i 1)))))))
(define (decode-unsigned-word byte-order bytes)
(let ((n (bytevector-length bytes)))
(let-values (((initial-shift shift-change)
(case byte-order
((big-endian)
(values (* 8 (- n 1)) -8))
((little-endian)
(values 0 8))
(else
(error "What?")))))
(let loop ((value 0) (shift initial-shift) (i 0))
(if (= i n) value
(loop (bitwise-ior
value
(arithmetic-shift (bytevector-u8-ref bytes i)
shift))
(+ shift shift-change)
(+ i 1)))))))
(define (peek-ints count n-byte byte-order signedness base)
(map (lambda (bytes)
(let* ((unsigned (decode-unsigned-word byte-order bytes))
(signed (case signedness
((unsigned)
unsigned)
((signed)
unsigned) ;TODO
(else
(error "What?")))))
(number->string signed base)))
(peek-bytevectors count n-byte)))
(define (peek-chars count n-byte byte-order)
#f)
(define (peek-floats count n-byte byte-order)
#f)
(define (peek* things)
(define (bad-thing thing)
(error "What?" thing))
(let ((count 1)
(n-byte 1)
(byte-order 'little-endian)
(signedness 'unsigned)
(base 16)
(decode 'ints))
(for-each (lambda (thing)
(cond ((and (integer? thing)
(exact-integer? thing)
(positive? thing))
(set! count thing))
((symbol? thing)
(case thing
((base-2 bin binary)
(set! base 2))
((base-8 oct octal)
(set! base 8))
((base-10 dec decimal)
(set! base 10))
((base-16 hex hexadecimal)
(set! base 16))
((big-endian little-endian)
(set! byte-order thing))
((signed unsigned)
(set! signedness thing))
((ints floats chars)
(set! decode thing))
((1-byte) (set! n-byte 1))
((2-byte) (set! n-byte 2))
((3-byte) (set! n-byte 3))
((4-byte) (set! n-byte 4))
((8-byte) (set! n-byte 8))
(else (bad-thing thing))))
(else
(bad-thing thing))))
things)
(case decode
((ints)
(peek-ints count n-byte byte-order signedness base))
((chars)
(peek-chars count n-byte byte-order signedness))
((floats)
(peek-floats count n-byte byte-order)))))
(define-syntax peek
(syntax-rules ()
((peek things ...)
(peek* '(things ...)))))))