Fix a few problems with the jump instructions (forgot to add #x05 to all of the conditional ones, too), make uint? and label? also recognise zero as valid and fix error expression of disassembler.

Implement back-and-forth transcoding of tcpdump's "decimal encoding" output of compiled packet matching instructions (using -ddd).
Fixed a few bugs I ran into with bitstring, so depend on the version to be released next (this code triggers error situations in the current version)

1 files changed, 55 insertions, 11 deletions

diff --git a/bpf-assembler.scm b/bpf-assembler.scm
index 07e7f39..9614fac 100644
--- a/bpf-assembler.scm
+++ b/bpf-assembler.scm
@@ -4,14 +4,15 @@
 ;;; Copyright (c) 2013 by Peter Bex, see file COPYING.BSD
 ;;;
 (module bpf-assembler
-        (exprs->bpf-bytecode bpf-bytecode->exprs)
+        (exprs->bpf-bytecode bpf-bytecode->exprs
+         read-decimal-bpf-bytecode write-decimal-bpf-bytecode)
 
 (import chicken scheme)
-(use srfi-1 bitstring matchable)
+(use extras srfi-1 bitstring matchable)
 
-(define (uint? x) (and (integer? x) (positive? x)))
-;; Is a jump of zero allowed?  It shouldn't be!
-(define (label? x) (and (integer? x) (< 0 x 256)))
+(define (uint? x) (and (integer? x) (or (zero? x) (positive? x))))
+;; Labels are jump offset from *next* instruction (a little surprising perhaps)
+(define (label? x) (and (integer? x) (<= 0 x 256)))
 
 ;; Basic idea stolen from sixtyfive-oh-two.  Thanks, Felix! ;)
 (begin-for-syntax
@@ -67,7 +68,7 @@
  (defaddrmode conditional-jump-index-register #x08
    (('x (and jt (? label?)) (and jf (? label?))) => jt jf 0) ; zero?
    (jt jf _ => (x ,jt ,jf)))
-
+ 
  (define-syntax defop
    (syntax-rules ()
      ((_ ?mnemonic ?opcode ?addrmode0 ...)
@@ -84,10 +85,10 @@
  (defop st   #x02 memory-ref)
  (defop stx  #x03 memory-ref)
  (defop jmp  #x05 immediate)            ; aka JA
- (defop jeq  #x10 conditional-jump-immediate conditional-jump-index-register)
- (defop jgt  #x20 conditional-jump-immediate conditional-jump-index-register)
- (defop jge  #x30 conditional-jump-immediate conditional-jump-index-register)
- (defop jset #x40 conditional-jump-immediate conditional-jump-index-register)
+ (defop jeq  #x15 conditional-jump-immediate conditional-jump-index-register)
+ (defop jgt  #x25 conditional-jump-immediate conditional-jump-index-register)
+ (defop jge  #x35 conditional-jump-immediate conditional-jump-index-register)
+ (defop jset #x45 conditional-jump-immediate conditional-jump-index-register)
  (defop add  #x04 index-register immediate)
  (defop sub  #x14 index-register immediate)
  (defop mul  #x24 index-register immediate)
@@ -159,7 +160,7 @@
                           ,(list 'quasiquote (cons mnemonic disasm-expr)))))
                     modes)))
                 (reverse opcodes))
-         (else "Unrecognised instruction" insn))))))
+         (else (error "Unrecognised instruction" (bitstring->list insn 8))))))))
 
 (define (bpf-bytecode->exprs bytecode)
   (let lp ((bytecode bytecode)
@@ -169,4 +170,47 @@
                (lp rest (cons (disassemble-instruction insn) exprs)))
               (() (reverse exprs)))))
 
+(define (read-number port)
+  (read-token char-whitespace? port)  ; First, skip any whitespace
+  (let* ((token (read-token (lambda (x) (not (char-whitespace? x))) port))
+         (num (string->number token)))
+    (unless (and num (integer? num) (or (zero? num) (positive? num)))
+      (receive pos (port-position port)
+        (error "Expected to read a positive integer" port pos token num)))
+    num))
+
+;; For reading bytecode from tcpdump's -dd output
+(define (read-decimal-bpf-bytecode
+         #!optional (port (current-input-port)) (count #f))
+  (let lp ((pos 0)
+           (count? (or (eq? count #f)
+                       (and (integer? count) (positive? count))))
+           (count (or count (read-number port)))
+           (bytecode (bitconstruct)))
+    (cond ((and count? (>= pos count)) bytecode)
+          ((eof-object? (peek-char port))
+           (if (not count?)
+               bytecode
+               (error "Expected more instructions due to count" count)))
+          (else
+           (let* ((op (read-number port))
+                  (jt (read-number port))
+                  (jf (read-number port))
+                  (k (read-number port)))
+             (lp (fx+ pos 1) count? count
+                 (bitstring-append
+                  bytecode (bitconstruct (op 16 host) (jt) (jf) (k 32 host)))))))))
+
+(define (write-decimal-bpf-bytecode
+         code #!optional (port (current-output-port)) raw-code?)
+  (let ((code (bitstring-of-any code)))
+    (unless raw-code?
+      (fprintf port "~A\n" (quotient (bitstring-length code) 64)))
+    (let lp ((code code))
+      (bitmatch code
+                (((op 16 host) (jt) (jf) (k 32 host) (rest bitstring))
+                 (fprintf port "~A ~A ~A ~A\n" op jt jf k)
+                 (lp rest))
+                (() (void))))))
+
 )