Add peek library

aplist.scm

@@ -31,11 +31,11 @@
 ;;; map
 
 (define (alist-map fn alist)
-  (reverse (alist-fold (lambda (key val acc) (cons (fn key val) acc))
+  (reverse (alist-fold (lambda (key val list) (cons (fn key val) list))
                        '() alist)))
 
 (define (plist-map fn plist)
-  (reverse (plist-fold (lambda (key val acc) (cons (fn key val) acc))
+  (reverse (plist-fold (lambda (key val list) (cons (fn key val) list))
                        '() plist)))
 
 ;;; ->

immutable-hashtable.sls

@@ -0,0 +1,173 @@
+(library (lassik immutable-hashtable)
+  (export make-eq-hashtable
+          make-eqv-hashtable
+          make-hashtable
+
+          hashtable-contains?
+          hashtable-entries
+          hashtable-equivalence-function
+          hashtable-hash-function
+          hashtable-keys
+          hashtable-mutable?
+          hashtable-ref
+          hashtable-size
+          hashtable?
+          immutable-hashtable?
+
+          equal-hash
+          string-ci-hash
+          string-hash
+          symbol-hash
+
+          hashtable-delete
+          hashtable-set
+          hashtable-update)
+  (import (rnrs base)
+          (rename (except (rnrs hashtables)
+                          make-hashtable
+                          make-eq-hashtable
+                          make-eqv-hashtable)
+                  (hashtable?
+                   rnrs-hashtable?)
+                  (hashtable-mutable?
+                   rnrs-hashtable-mutable?)
+                  (hashtable-size
+                   rnrs-hashtable-size)
+                  (hashtable-contains?
+                   rnrs-hashtable-contains?)
+                  (hashtable-entries
+                   rnrs-hashtable-entries)
+                  (hashtable-equivalence-function
+                   rnrs-hashtable-equivalence-function)
+                  (hashtable-hash-function
+                   rnrs-hashtable-hash-function)
+                  (hashtable-keys
+                   rnrs-hashtable-keys)
+                  (hashtable-ref
+                   rnrs-hashtable-ref)))
+  (begin
+
+    ;; From SRFI 1.
+    (define (append-reverse list1 list2)
+      (append (reverse list1) list2))
+
+    ;; From R7RS.
+    (define (assoc key alist equivalent?)
+      (cond ((null? alist) #f)
+            ((equivalent? key (caar alist)) (car alist))
+            (else (assoc key (cdr alist) equivalent?))))
+
+    ;;
+
+    (define (immutable-hashtable? obj)
+      (and (vector? obj) (eq? 'immutable-hashtable (vector-ref obj 0))))
+
+    (define (hashtable? obj)
+      (or (rnrs-hashtable? obj)
+          (immutable-hashtable? obj)))
+
+    (define (hashtable-mutable? table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-mutable? table)
+          #f))
+
+    ;;
+
+    (define (make-hashtable* hash equivalent? alist)
+      (vector 'immutable-hashtable hash equivalent? alist))
+
+    (define (make-hashtable hash equivalent?)
+      (make-hashtable* hash equivalent? '()))
+
+    (define (make-eq-hashtable)
+      (make-hashtable #f eq?))
+
+    (define (make-eqv-hashtable)
+      (make-hashtable #f eqv?))
+
+    ;;
+
+    (define (hashtable-hash-function table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-hash-function table)
+          (vector-ref table 1)))
+
+    (define (hashtable-equivalence-function table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-equivalence-function table)
+          (vector-ref table 2)))
+
+    (define (hashtable-alist table)
+      (vector-ref table 3))
+
+    (define (hashtable-assoc table key)
+      (assoc key
+             (hashtable-alist table)
+             (hashtable-equivalence-function table)))
+
+    ;;
+
+    (define (hashtable-contains? table key)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-contains? table key)
+          (not (not (hashtable-assoc table key)))))
+
+    (define (hashtable-keys table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-keys table)
+          (list->vector (map car (hashtable-alist table)))))
+
+    (define (hashtable-entries table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-entries table)
+          (values (list->vector (map car (hashtable-alist table)))
+                  (list->vector (map cdr (hashtable-alist table))))))
+
+    (define (hashtable-ref table key default)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-ref table key default)
+          (let ((entry (hashtable-assoc table key)))
+            (if entry (cdr entry) default))))
+
+    (define (hashtable-size table)
+      (if (rnrs-hashtable? table)
+          (rnrs-hashtable-size table)
+          (length (hashtable-alist table))))
+
+    ;;
+
+    (define (hashtable-delete table key)
+      (let ((equivalent? (hashtable-equivalence-function table)))
+        (make-hashtable*
+         (hashtable-hash-function table)
+         equivalent?
+         (let loop ((old-alist (hashtable-alist table))
+                    (new-alist '()))
+           (if (null? old-alist) (reverse new-alist)
+               (loop (cdr old-alist)
+                     (if (equivalent? key (caar old-alist))
+                         new-alist
+                         (cons (car old-alist) new-alist))))))))
+
+    (define (hashtable-update table key update default)
+      (let ((equivalent? (hashtable-equivalence-function table)))
+        (make-hashtable*
+         (hashtable-hash-function table)
+         equivalent?
+         (let loop ((old-alist (hashtable-alist table))
+                    (new-alist '()))
+           (cond ((null? old-alist)
+                  (reverse (cons (cons key (update default))
+                                 new-alist)))
+                 ((equivalent? key (caar old-alist))
+                  (append-reverse (cons (cons (caar old-alist)
+                                              (update (cdar old-alist)))
+                                        new-alist)
+                                  (cdr old-alist)))
+                 (else
+                  (loop (cdr old-alist)
+                        (cons (car old-alist)
+                              new-alist))))))))
+
+    (define (hashtable-set table key value)
+      (hashtable-update table key (lambda (_) value) #f))))

library-inspection.chibi.scm

@@ -0,0 +1,7 @@
+(define (library-list)
+  (map car *modules*))
+
+(define (library-exports library-name)
+  (let ((m (cdr (or (assoc library-name *modules*)
+                    (error "No such library" library-name)))))
+    (env-exports (module-env m))))

library-inspection.gauche.scm

@@ -0,0 +1,64 @@
+(define (module-name->library-name module-name)
+
+  (define (split-at char string)
+    (let loop ((a 0) (b 0) (parts '()))
+      (cond ((= a b (string-length string))
+             (reverse parts))
+            ((= b (string-length string))
+             (loop b b (cons (substring string a b) parts)))
+            ((char=? char (string-ref string b))
+             (loop (+ b 1) (+ b 1) (cons (substring string a b) parts)))
+            (else
+             (loop a (+ b 1) parts)))))
+
+  (define (string->library-name-part string)
+    (or (string->number string)
+        (string->symbol string)))
+
+  (define (srfi-number string)
+    (let ((srfi- "srfi-"))
+      (and (> (string-length string) (string-length srfi-))
+           (string=? srfi- (substring string 0 (string-length srfi-)))
+           (string->number (substring string (string-length srfi-)
+                                      (string-length string))))))
+
+  (let* ((string (symbol->string module-name))
+         (number (srfi-number string)))
+    (if number
+        `(srfi ,number)
+        (map string->library-name-part (split-at #\. string)))))
+
+(define (library-name->module-name library-name)
+
+  (define (string-join strings delim)
+    (if (null? strings) ""
+        (let loop ((acc (car strings)) (strings (cdr strings)))
+          (if (null? strings) acc
+              (loop (string-append acc delim (car strings))
+                    (cdr strings))))))
+
+  (define (library-name-part->string part)
+    (if (number? part) (number->string part) (symbol->string part)))
+
+  (string->symbol
+   (if (and (= (length library-name) 2)
+            (eq? 'srfi (car library-name))
+            (number? (cadr library-name)))
+       (string-append "srfi-" (number->string (cadr library-name)))
+       (string-join (map library-name-part->string library-name)
+                    "."))))
+
+(define (library-list)
+  (map (lambda (m) (module-name->library-name (module-name m)))
+       (all-modules)))
+
+(define (library-exports library-name)
+  (define (remove match? list)
+    (let loop ((acc '()) (list list))
+      (if (null? list) (reverse acc)
+          (loop (if (match? (car list)) acc (cons (car list) acc))
+                (cdr list)))))
+  (let ((m (find-module (library-name->module-name library-name))))
+    (if m (remove (lambda (x) (memq x '(*1 *1+ *2 *2+ *3 *3+ *e *history)))
+                  (module-exports m))
+        (error "No such library" library-name))))

library-inspection.sld

@@ -15,61 +15,5 @@
                   module-exports
                   module-name))))
   (cond-expand
-
-   (chibi
-    (begin
-
-      (define (library-list)
-        (map car *modules*))
-
-      (define (library-exports library-name)
-        (let ((m (cdr (or (assoc library-name *modules*)
-                          (error "No such library" library-name)))))
-          (env-exports (module-env m))))))
-
-   (gauche
-    (begin
-
-      (define (module-name->library-name module-name)
-        (define (split-at char string)
-          (let loop ((a 0) (b 0) (parts '()))
-            (cond ((= a b (string-length string))
-                   (reverse parts))
-                  ((= b (string-length string))
-                   (loop b b (cons (substring string a b) parts)))
-                  ((char=? char (string-ref string b))
-                   (loop (+ b 1) (+ b 1) (cons (substring string a b) parts)))
-                  (else
-                   (loop a (+ b 1) parts)))))
-        (define (string->library-name-part string)
-          (or (string->number string)
-              (string->symbol string)))
-        (map string->library-name-part
-             (split-at #\. (symbol->string module-name))))
-
-      (define (library-name->module-name library-name)
-        (define (string-join strings delim)
-          (if (null? strings) ""
-              (let loop ((acc (car strings)) (strings (cdr strings)))
-                (if (null? strings) acc
-                    (loop (string-append acc delim (car strings))
-                          (cdr strings))))))
-        (define (library-name-part->string part)
-          (if (number? part) (number->string part) (symbol->string part)))
-        (string->symbol
-         (string-join (map library-name-part->string library-name) ".")))
-
-      (define (library-list)
-        (map (lambda (m) (module-name->library-name (module-name m)))
-             (all-modules)))
-
-      (define (library-exports library-name)
-        (define (remove match? list)
-          (let loop ((acc '()) (list list))
-            (if (null? list) (reverse acc)
-                (loop (if (match? (car list)) acc (cons (car list) acc))
-                      (cdr list)))))
-        (let ((m (find-module (library-name->module-name library-name))))
-          (if m (remove (lambda (x) (memq x '(*1 *3+ *1+ *2+ *e *3 *history *2)))
-                        (module-exports m))
-              (error "No such library" library-name))))))))
+   (chibi  (include "library-inspection.chibi.scm"))
+   (gauche (include "library-inspection.gauche.scm"))))

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 ...)))))))