Add initial COFF object parsing

ober

8d7ff6bc98542ea93215fc506de013da905abc09

diff --git a/docs/plan.md b/docs/plan.md
index 5ee38f7..c41ea56 100644
--- a/docs/plan.md
+++ b/docs/plan.md
@@ -52,6 +52,8 @@ reference material and parity targets.
   section tables, plus `LC_SYMTAB` symbol tables. The CLI detects ELF vs.
   Mach-O for `headers`, `sections`, `symbols`, and executable-section
   disassembly.
+- `(jasm object coff)` can parse initial COFF/PE headers and section tables.
+  The shared CLI object path can disassemble executable COFF sections.
 
 ## Core Architecture
 
@@ -251,9 +253,9 @@ Implement after ELF/Mach-O.
 
 Required:
 
-- COFF file header.
+- COFF file header. Initial parser is implemented.
 - Optional header.
-- Section table.
+- Section table. Initial parser is implemented.
 - Symbol table.
 - String table.
 - Relocations.
diff --git a/jasm b/jasm
index 6ce4cae..c66bc20 100755
Binary files a/jasm and b/jasm differ
diff --git a/lib/jasm/object/coff.ss b/lib/jasm/object/coff.ss
new file mode 100644
index 0000000..bdf93d2
--- /dev/null
+++ b/lib/jasm/object/coff.ss
@@ -0,0 +1,183 @@
+#!chezscheme
+
+(library (jasm object coff)
+  (export
+    read-coff-bytevector
+    read-coff-file
+    coff-object?
+    coff-object-kind
+    coff-object-machine
+    coff-object-architecture
+    coff-object-sections
+    coff-section?
+    coff-section-index
+    coff-section-name
+    coff-section-characteristics
+    coff-section-address
+    coff-section-offset
+    coff-section-size
+    coff-section-executable?
+    coff-section-by-name
+    coff-executable-sections
+    coff-section-bytes)
+
+  (import (chezscheme))
+
+  (define (make-coff-object kind machine sections path bytes)
+    (vector 'coff-object kind machine sections path bytes))
+
+  (define (coff-object? x)
+    (and (vector? x)
+         (= (vector-length x) 6)
+         (eq? (vector-ref x 0) 'coff-object)))
+
+  (define (coff-object-kind obj) (vector-ref obj 1))
+  (define (coff-object-machine obj) (vector-ref obj 2))
+  (define (coff-object-sections obj) (vector-ref obj 3))
+  (define (coff-object-path obj) (vector-ref obj 4))
+  (define (coff-object-bytes obj) (vector-ref obj 5))
+
+  (define (make-coff-section index name characteristics address offset size)
+    (vector 'coff-section index name characteristics address offset size))
+
+  (define (coff-section? x)
+    (and (vector? x)
+         (= (vector-length x) 7)
+         (eq? (vector-ref x 0) 'coff-section)))
+
+  (define (coff-section-index section) (vector-ref section 1))
+  (define (coff-section-name section) (vector-ref section 2))
+  (define (coff-section-characteristics section) (vector-ref section 3))
+  (define (coff-section-address section) (vector-ref section 4))
+  (define (coff-section-offset section) (vector-ref section 5))
+  (define (coff-section-size section) (vector-ref section 6))
+
+  (define (bv-len bv) (bytevector-length bv))
+
+  (define (require-range who bv offset size)
+    (when (or (< offset 0)
+              (< size 0)
+              (> (+ offset size) (bv-len bv)))
+      (error who "COFF data is truncated" offset size (bv-len bv))))
+
+  (define (u8 bv offset)
+    (require-range 'read-coff-bytevector bv offset 1)
+    (bytevector-u8-ref bv offset))
+
+  (define (u16 bv offset)
+    (require-range 'read-coff-bytevector bv offset 2)
+    (+ (u8 bv offset)
+       (* (u8 bv (+ offset 1)) #x100)))
+
+  (define (u32 bv offset)
+    (require-range 'read-coff-bytevector bv offset 4)
+    (+ (u8 bv offset)
+       (* (u8 bv (+ offset 1)) #x100)
+       (* (u8 bv (+ offset 2)) #x10000)
+       (* (u8 bv (+ offset 3)) #x1000000)))
+
+  (define (slice-bytevector bv offset size)
+    (require-range 'coff-section-bytes bv offset size)
+    (let ([out (make-bytevector size 0)])
+      (bytevector-copy! bv offset out 0 size)
+      out))
+
+  (define (read-file-bytevector path)
+    (let ([port (open-file-input-port path)])
+      (let ([bytes (get-bytevector-all port)])
+        (close-port port)
+        bytes)))
+
+  (define (read-fixed-string bv offset size)
+    (require-range 'read-coff-bytevector bv offset size)
+    (let loop ([i 0] [chars '()])
+      (cond
+        [(= i size) (list->string (reverse chars))]
+        [(zero? (u8 bv (+ offset i))) (list->string (reverse chars))]
+        [else (loop (+ i 1) (cons (integer->char (u8 bv (+ offset i))) chars))])))
+
+  (define (coff-object-architecture obj)
+    (case (coff-object-machine obj)
+      [(#x8664) 'x86-64]
+      [(#xaa64) 'aarch64]
+      [(#x0166 #x0266 #x0366 #x0466) 'mips]
+      [else (error 'coff-object-architecture "unsupported COFF machine" (coff-object-machine obj))]))
+
+  (define (pe-header-offset bv)
+    (and (>= (bv-len bv) #x40)
+         (= (u8 bv 0) (char->integer #\M))
+         (= (u8 bv 1) (char->integer #\Z))
+         (let ([offset (u32 bv #x3c)])
+           (and (<= (+ offset 4) (bv-len bv))
+                (= (u8 bv offset) (char->integer #\P))
+                (= (u8 bv (+ offset 1)) (char->integer #\E))
+                (zero? (u8 bv (+ offset 2)))
+                (zero? (u8 bv (+ offset 3)))
+                (+ offset 4)))))
+
+  (define (coff-header-offset bv)
+    (or (pe-header-offset bv) 0))
+
+  (define (known-machine? machine)
+    (memv machine '(#x8664 #xaa64 #x0166 #x0266 #x0366 #x0466)))
+
+  (define (parse-section bv offset index)
+    (make-coff-section
+      index
+      (read-fixed-string bv offset 8)
+      (u32 bv (+ offset 36))
+      (u32 bv (+ offset 12))
+      (u32 bv (+ offset 20))
+      (u32 bv (+ offset 16))))
+
+  (define (parse-sections bv sections-offset count)
+    (let loop ([index 0] [sections '()])
+      (if (= index count)
+          (reverse sections)
+          (let ([offset (+ sections-offset (* index 40))])
+            (require-range 'read-coff-bytevector bv offset 40)
+            (loop (+ index 1)
+                  (cons (parse-section bv offset index) sections))))))
+
+  (define (read-coff-bytevector bv . maybe-path)
+    (let* ([path (if (null? maybe-path) #f (car maybe-path))]
+           [header (coff-header-offset bv)])
+      (require-range 'read-coff-bytevector bv header 20)
+      (let* ([machine (u16 bv header)]
+             [section-count (u16 bv (+ header 2))]
+             [optional-size (u16 bv (+ header 16))]
+             [sections-offset (+ header 20 optional-size)]
+             [kind (if (zero? header) 'coff 'pe)])
+        (unless (known-machine? machine)
+          (error 'read-coff-bytevector "unsupported COFF machine" machine))
+        (make-coff-object kind
+                          machine
+                          (parse-sections bv sections-offset section-count)
+                          path
+                          bv))))
+
+  (define (read-coff-file path)
+    (read-coff-bytevector (read-file-bytevector path) path))
+
+  (define (coff-section-executable? section)
+    (not (zero? (bitwise-and (coff-section-characteristics section) #x20000020))))
+
+  (define (coff-section-by-name obj name)
+    (let loop ([sections (coff-object-sections obj)])
+      (cond
+        [(null? sections) #f]
+        [(string=? (coff-section-name (car sections)) name) (car sections)]
+        [else (loop (cdr sections))])))
+
+  (define (coff-executable-sections obj)
+    (let loop ([sections (coff-object-sections obj)] [out '()])
+      (cond
+        [(null? sections) (reverse out)]
+        [(coff-section-executable? (car sections))
+         (loop (cdr sections) (cons (car sections) out))]
+        [else (loop (cdr sections) out)])))
+
+  (define (coff-section-bytes obj section)
+    (slice-bytevector (coff-object-bytes obj)
+                      (coff-section-offset section)
+                      (coff-section-size section))))
diff --git a/main.ss b/main.ss
index c13ae75..1c75345 100644
--- a/main.ss
+++ b/main.ss
@@ -1,6 +1,10 @@
 #!chezscheme
 
-(import (chezscheme) (jasm disasm) (jasm object elf) (jasm object macho))
+(import (chezscheme)
+        (jasm disasm)
+        (jasm object elf)
+        (jasm object macho)
+        (jasm object coff))
 
 (define (usage)
   (display "Usage:\n")
@@ -47,6 +51,10 @@
       [(or (bytevector-prefix? bytes '(#xcf #xfa #xed #xfe))
            (bytevector-prefix? bytes '(#xfe #xed #xfa #xcf)))
        (read-macho-bytevector bytes path)]
+      [(or (bytevector-prefix? bytes '(#x64 #x86))
+           (bytevector-prefix? bytes '(#x64 #xaa))
+           (bytevector-prefix? bytes '(#x4d #x5a)))
+       (read-coff-bytevector bytes path)]
       [else (error 'jasm "unsupported object file format" path)])))
 
 (define (option-cons key value options)
@@ -128,6 +136,20 @@
   (cond
     [(elf-object? obj) (print-elf-headers obj)]
     [(macho-object? obj) (print-macho-headers obj)]
+    [(coff-object? obj)
+     (display "Format: ")
+     (display (if (eq? (coff-object-kind obj) 'pe) "PE/COFF" "COFF"))
+     (newline)
+     (display "Machine: ")
+     (display (hex-number (coff-object-machine obj)))
+     (newline)
+     (display "Architecture: ")
+     (guard (exn [#t (display "unsupported")])
+       (display (coff-object-architecture obj)))
+     (newline)
+     (display "Sections: ")
+     (display (length (coff-object-sections obj)))
+     (newline)]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (print-elf-section-row section)
@@ -162,6 +184,21 @@
   (display (hex-number (macho-section-flags section)))
   (newline))
 
+(define (print-coff-section-row section)
+  (display "[")
+  (display (coff-section-index section))
+  (display "] ")
+  (display (coff-section-name section))
+  (display "\taddr=")
+  (display (hex-number (coff-section-address section)))
+  (display "\toff=")
+  (display (hex-number (coff-section-offset section)))
+  (display "\tsize=")
+  (display (hex-number (coff-section-size section)))
+  (display "\tflags=")
+  (display (hex-number (coff-section-characteristics section)))
+  (newline))
+
 (define (print-elf-sections obj)
   (for-each print-elf-section-row (elf-object-sections obj)))
 
@@ -172,6 +209,7 @@
   (cond
     [(elf-object? obj) (print-elf-sections obj)]
     [(macho-object? obj) (print-macho-sections obj)]
+    [(coff-object? obj) (for-each print-coff-section-row (coff-object-sections obj))]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (section-name-by-index obj index)
@@ -261,36 +299,42 @@
   (cond
     [(elf-object? obj) (elf-object-architecture obj)]
     [(macho-object? obj) (macho-object-architecture obj)]
+    [(coff-object? obj) (coff-object-architecture obj)]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (object-section-by-name obj name)
   (cond
     [(elf-object? obj) (elf-section-by-name obj name)]
     [(macho-object? obj) (macho-section-by-name obj name)]
+    [(coff-object? obj) (coff-section-by-name obj name)]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (object-executable-sections obj)
   (cond
     [(elf-object? obj) (elf-executable-sections obj)]
     [(macho-object? obj) (macho-executable-sections obj)]
+    [(coff-object? obj) (coff-executable-sections obj)]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (object-section-name section)
   (cond
     [(elf-section? section) (elf-section-name section)]
     [(macho-section? section) (macho-section-full-name section)]
+    [(coff-section? section) (coff-section-name section)]
     [else (error 'jasm "unsupported section record" section)]))
 
 (define (object-section-address section)
   (cond
     [(elf-section? section) (elf-section-address section)]
     [(macho-section? section) (macho-section-address section)]
+    [(coff-section? section) (coff-section-address section)]
     [else (error 'jasm "unsupported section record" section)]))
 
 (define (object-section-bytes obj section)
   (cond
     [(elf-object? obj) (elf-section-bytes obj section)]
     [(macho-object? obj) (macho-section-bytes obj section)]
+    [(coff-object? obj) (coff-section-bytes obj section)]
     [else (error 'jasm "unsupported object record" obj)]))
 
 (define (one-file args command-name)
diff --git a/tests/test-jasm.ss b/tests/test-jasm.ss
index 478d9d9..d3e6fbf 100644
--- a/tests/test-jasm.ss
+++ b/tests/test-jasm.ss
@@ -1,6 +1,11 @@
 #!chezscheme
 
-(import (chezscheme) (jasm disasm) (jasm format) (jasm object elf) (jasm object macho))
+(import (chezscheme)
+        (jasm disasm)
+        (jasm format)
+        (jasm object elf)
+        (jasm object macho)
+        (jasm object coff))
 
 (define pass 0)
 (define fail 0)
@@ -173,6 +178,39 @@
     (put-ascii! #x140 (string #\nul #\_ #\f #\u #\n #\c #\nul))
     bv))
 
+(define (sample-coff-x64)
+  (let ([bv (make-bytevector #x200 0)])
+    (define (put8! offset value)
+      (bytevector-u8-set! bv offset (modulo value #x100)))
+    (define (put16le! offset value)
+      (put8! offset value)
+      (put8! (+ offset 1) (quotient value #x100)))
+    (define (put32le! offset value)
+      (put8! offset value)
+      (put8! (+ offset 1) (quotient value #x100))
+      (put8! (+ offset 2) (quotient value #x10000))
+      (put8! (+ offset 3) (quotient value #x1000000)))
+    (define (put-ascii! offset s)
+      (let ([n (string-length s)])
+        (let loop ([i 0])
+          (when (< i n)
+            (put8! (+ offset i) (char->integer (string-ref s i)))
+            (loop (+ i 1))))))
+    (put16le! 0 #x8664)
+    (put16le! 2 1)
+    (put32le! 4 0)
+    (put32le! 8 0)
+    (put32le! 12 0)
+    (put16le! 16 0)
+    (put16le! 18 0)
+    (put-ascii! #x14 ".text")
+    (put32le! #x20 #x1000)
+    (put32le! #x24 5)
+    (put32le! #x28 #x100)
+    (put32le! #x38 #x60000020)
+    (put-ascii! #x100 (string #\x55 #\xc3 #\x90 #\x90 #\xc3))
+    bv))
+
 (printf "--- jasm tests ---~%")
 
 (test "hex parser"
@@ -285,6 +323,24 @@
           (macho-symbol-value symbol)))
   '(1 #t "_func" 15 1 4096))
 
+(test "coff section discovery"
+  (let* ([obj (read-coff-bytevector (sample-coff-x64))]
+         [text (coff-section-by-name obj ".text")])
+    (list (coff-object? obj)
+          (coff-object-kind obj)
+          (coff-object-architecture obj)
+          (coff-section? text)
+          (coff-section-address text)
+          (coff-section-executable? text)
+          (map coff-section-name (coff-executable-sections obj))))
+  '(#t coff x86-64 #t 4096 #t (".text")))
+
+(test "coff section bytes"
+  (let* ([obj (read-coff-bytevector (sample-coff-x64))]
+         [text (coff-section-by-name obj ".text")])
+    (bytevector->u8-list (coff-section-bytes obj text)))
+  '(85 195 144 144 195))
+
 (test "instruction records are vector-backed"
   (let ([insn (car (disassemble-bytevector 'x86-64 (hex-string->bytevector "55")))])
     (list (instruction? insn)