From 118dd55027ef014ea43e95c1655430725a53a0b0 Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Wed, 29 Sep 2021 19:20:34 +0300
Subject: [PATCH] Add peek library

---
 peek.sld | 150 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 150 insertions(+)
 create mode 100644 peek.sld

diff --git a/peek.sld b/peek.sld
new file mode 100644
index 0000000..3c519d0
--- /dev/null
+++ b/peek.sld
@@ -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 ...)))))))