Welcome to the CHICKEN Scheme pasting service

(define-record bitstring
  offset  ; offset in bits
  numbits ; length of the bitstring in bits
  buffer) ; vector

(define-record-printer (bitstring x out)
  (fprintf out "bitstring ~A" (bitstring-buffer x)))

(define (bitstring-reserve numbits)
  (let* ((n (quotient numbits 8))
      	 (rem (remainder numbits 8))
    	 (aligned-size (if (zero? rem) n (+ 1 n))))
    (make-bitstring 0 numbits (make-vector aligned-size 0))))

(define (bitstring-of-vector v)
  (let* ((size (vector-length v))
         (numbits (* 8 size)))
    (make-bitstring 0 numbits v)))
    
(define (bitstring-load-byte bs index)
  (vector-ref (bitstring-buffer bs) index))
 
(define (bitstring-store-byte bs index value)
  (vector-set! (bitstring-buffer bs) index (bitwise-and #xFF value)))
  
(define (integer->bitstring endian value count)
  (cond
    ((eq? endian 'big)
      (integer->bitstring-big (bitstring-reserve count) 0 value count))
    ((eq? endian 'little)
      (integer->bitstring-little (bitstring-reserve count) #f value count))))

(define (integer->bitstring-big bs index value count)
  (let ((n (min 8 count)))
    (cond
      ((< n 8)
      	(bitstring-store-byte bs index (arithmetic-shift value (- 8 n)))
      	bs);return bitstring
      (else
      	(bitstring-store-byte bs index (arithmetic-shift value (- n count)))
      	(integer->bitstring-big bs (+ index 1) value (- count n))))))

(define (integer->bitstring-little bs index value count)
  (cond
    ((zero? count)
      bs)
    ((eq? index #f)
      (let* ((r (remainder count 8))
      	     (n (- 8 r))
             (index (quotient count 8)))
      	(bitstring-store-byte bs index (arithmetic-shift value n))
      	;(print " index=" index " count=" count " n=" n " value=" (bitmask8 value 8) " store=" (bitstring-load-byte bs index))
      	(integer->bitstring-little bs (- index 1)
      	  (arithmetic-shift value (- r)) (- count r)))) 
    (else
      (let ((n 8))
      	(bitstring-store-byte bs index value)
      	;(print " index=" index " count=" count " n=" n " store=" (bitstring-load-byte bs index))
      	(integer->bitstring-little bs (- index 1)
      	  (arithmetic-shift value (- n)) (- count n))))))

(define (bitstring->integer bs endian)
  (cond 
    ((eq? endian 'big)
      (bitstring->integer-big bs (bitstring-numbits bs) 0 0))
    ((eq? endian 'little)
      (bitstring->integer-little bs (bitstring-numbits bs) 0 0))))

(define (bitstring->integer-big bs count index acc)
  (print "big count=" count " index=" index)
  (let* ((n (min 8 count))
         (shift (- n 8)))
    (cond
      ((zero? count)
      	acc)
      ((< n 8)
      	(bitwise-ior
      	  (arithmetic-shift (bitstring-load-byte bs index) shift)
      	  (arithmetic-shift acc n)))
      (else
      	(bitstring->integer-big bs (- count n) (+ 1 index)
      	  (bitwise-ior
      	    (arithmetic-shift (bitstring-load-byte bs index) (- n 8))
      	    (arithmetic-shift acc n)))))))
  
(define (bitstring->integer-little bs count index acc)
  (let* ((n (min 8 count)))
    (print "count=" count " n=" n)
    (if (zero? n)
      acc
      (bitstring->integer-little bs (- count n) (+ 1 index)
      	(bitwise-ior
      	  (arithmetic-shift (bitstring-load-byte bs index) (- n))
      	  (arithmetic-shift acc (- n)))))))
      	  
(define (bitstring-append-safe bs value count)
  (if (zero? count)
    bs
    (let* ((offset (bitstring-offset bs))
    	   (index (quotient offset 8))
           (drift (remainder offset 8))
           (space (- 8 drift))
           (nbits (min count space))
           (byte1 (bitstring-load-byte bs index))
           (byte2 (bitmask8 (arithmetic-shift value (- count nbits)) nbits)))
      (bitstring-store-byte bs index ; blend bits
      	(bitwise-ior byte1 (arithmetic-shift byte2 (- space nbits))))
      ;(print "store offset=" offset " value=" (bitstring-load-byte bs index) 
      ;	" space=" space " shift=" (- count nbits) " bits=" nbits)
      (bitstring-offset-set! bs (+ offset nbits))
      (bitstring-append-safe bs value (- count nbits)))))

(define (bitstring-read-bits bs count)
  (assert (>= count 0))
  (let ((offset (bitstring-offset bs))
	(limit (bitstring-numbits bs)))
    (if (<= (+ offset count) limit)
      (let ((acc (bitstring-reserve count)))
      	(bitstring-read-bits-safe bs offset count acc)
      	(bitstring-offset-set! bs (+ offset count))
      	acc)
      #f)))

(define (bitstring-read-bits-safe bs offset count acc)
  (if (= count 0)
    acc
    (let* ((index (quotient offset 8))
    	   (drift (remainder offset 8))
    	   (nbits (min 8 count (- 8 drift)))
    	   (shift (- offset (* 8 index)))
    	   (byte (bitstring-load-byte bs index))
    	   (value (extract-bits byte nbits shift)))
      ;(print "offs=" offset " nbits=" nbits " byte=" byte " value=" value)
      (bitstring-read-bits-safe bs (+ offset nbits) (- count nbits)
      	(bitstring-append-safe acc value nbits)))))

(define (bitmask8 value nbits)
  (case nbits
    ((0) 0)
    ((1) (bitwise-and value #b00000001))
    ((2) (bitwise-and value #b00000011))
    ((3) (bitwise-and value #b00000111))
    ((4) (bitwise-and value #b00001111))
    ((5) (bitwise-and value #b00011111))
    ((6) (bitwise-and value #b00111111))
    ((7) (bitwise-and value #b01111111))
    ((8) (bitwise-and value #b11111111))))

(define (extract-bits byte nbits shift)
  (let* ((n (- (+ nbits shift) 8))
         (value (arithmetic-shift byte n)))
    (bitmask8 value nbits)))


(define (bitmatch-open v)
  (print "bitmatch-open " v)
  (bitstring-of-vector v))

(define (bitmatch-reset stream)
  (print "bitmatch-reset ")
  (bitstring-offset-set! stream 0))

(define (bitmatch-read stream num-bits)
  (let ((bs (bitstring-read-bits stream num-bits)))
    (print " read " num-bits " " bs) 
    (and
      bs
      (bitstring->integer bs 'big))))  

(define (bitmatch-compare a b)
  (print "compare " a " = " b)
  (equal? a b))

(define-syntax bitmatch
  (syntax-rules ()
    ((_ value patterns ...)
      (let ((stream (bitmatch-open value)))
      	(call-with-current-continuation
      	  (lambda (k)
      	    (or (bitmatch2 ('secret-params stream k) patterns ...))))))))

(define-syntax bitmatch2
  (syntax-rules (else)
    ((_ ('secret-params stream k))
      (print "error: nothing match"))
    ((_ ('secret-params stream k) (else expression))
      (print "else condition"))    	
    ((_ ('secret-params stream k) (pattern ...) rest ...)
      (or
      	(begin
      	  (print "group: " `(pattern ...))
      	  (bitmatch-reset stream)
      	  #f)
	(and
	  (bitmatch1 ('secret-params stream k) pattern ...))
	(bitmatch2 ('secret-params stream k) rest ...)))
    ((_ err)
      (print "bad pattern: " `err))))


(define-syntax bitmatch1
  (syntax-rules (let : ->) ; CAUTION: use let* during macro expansion !!!
    ((_ ('secret-params stream k)
    	(let name : num-bits) rest ...)
      (and
      	(let* ((name (bitmatch-read stream num-bits)))
      	  (print "bind variable " name)
      	  (and
      	    (not (eq? #f name))
      	    (bitmatch1 ('secret-params stream k) rest ...)))))

    ((_ ('secret-params stream k)
    	(let name : num-bits : signed) rest ...)
      (and
      	(bitmatch1 ('secret-params stream k) rest ...)))

    ((_ ('secret-params stream k) (var name : num-bits : unsigned) rest ...)
      (and
      	(bitmatch1 ('secret-params stream k) rest ...)))

    ((_ ('secret-params stream k)
    	(value : num-bits) rest ...)
      (and
      	(begin (print "value=?") #t)
      	(bitmatch1 ('secret-params stream k) rest ...)))

    ((_ ('secret-params stream k)
    	(value) rest ...)
      (and
      	(let* ((bits (bitmatch-read stream 8)))
      	  (print "value=" bits)
      	  (and
      	    (bitmatch-compare value bits)
      	    (bitmatch1 ('secret-params stream k) rest ...)))))

    ((_ ('secret-params stream k)
    	-> expression)
      (begin
      	(print "match! " `expression)
      	(k expression)))
     ((_ ('secret-params stream k))
      (print "empty expression"))
    
    ((_ ('secret-params stream k) err1)
      (print "malformed pattern1 " `err1))
    
    ((_ ('secret-params stream k) err2 rest ...)
      (print "malformed pattern2 " `err2))))

(print "-\n")

(bitmatch '#(130 50)
  ((let a : 1) (let b : 7) (50 : 18) ->
    (print " a=" a " b=" b)))