#lang racket
(provide WORD-SIZE HEADER-SIZE MERL-COOKIE REL ESR ESD)
(provide read-word read-words write-word write-word-readable)
(provide (struct-out entry) entry-size read-entry read-entries write-entry)
(provide (struct-out merl) read-merl write-merl)

(define WORD-SIZE 4)
(define HEADER-SIZE 12)
(define MERL-COOKIE #x10000002)
(define REL #x01)
(define ESD #x05)
(define ESR #x11)

; Print an error message to standard error and exit
(define (err message)
  (eprintf "ERROR: ~a~n" message)
  (exit))

; Read one word from an input port
(define (read-word [in (current-input-port)])
  (define bytes (build-vector WORD-SIZE (lambda (n) (read-byte in))))
  (cond [(vector-member eof bytes)
          (err "Unexpected end of file when reading word")]
        [else
          (apply bitwise-ior
                 (for/list ([shift (in-range (* 8 (- WORD-SIZE 1)) -1 -8)]
                            [i     (in-range WORD-SIZE)])
                           (arithmetic-shift (vector-ref bytes i) shift)))]))

; Read a specific number of words from an input port
; Return the words in a list
(define (read-words words-left [in (current-input-port)])
  (cond [(> words-left 0) (cons (read-word in) (read-words (- words-left 1) in))]
        [else empty]))

; Write a word to an output port in human-readable hex 
(define (write-word-readable word [out (current-output-port)])
  (displayln (~r word #:base 16 #:min-width 8 #:pad-string "0") out))

; Write a word to an output port in binary
(define (write-word word [out (current-output-port)])
  (for-each (lambda (byte) (write-byte byte out))
            (for/list ([shift (in-range (* 8 (- WORD-SIZE 1)) -1 -8)])
                      (bitwise-and (arithmetic-shift word (- shift)) #xFF))))

; Struct for entries in the MERL footer table
(struct entry (format-code location name) #:mutable #:transparent)

; Return the size of an entry in words
(define (entry-size e)
  (cond [(equal? (entry-format-code e) REL) 2]
        [else (+ 3 (string-length (entry-name e)))]))

; Read one entry from an input port
(define (read-entry [in (current-input-port)])
  (define format-code (read-word in))
  (define location (read-word in))
  (define name 
    (cond [(equal? format-code REL) ""]
          [else
            (define len (read-word in))
            (list->string 
              (map (lambda (v) (integer->char v)) 
                   (read-words len in)))]))
  (entry format-code location name))

; Read entries from an input port until the given number of words is exhausted
; Return the entries in a list
(define (read-entries words-left [in (current-input-port)])
  (cond [(> words-left 0) 
          (define e (read-entry in))
          (cons e (read-entries (- words-left (entry-size e)) in))]
        [else empty]))

; Write an entry to an output port
; Format is specified by passing a one-argument function that prints a word
; (Default format is binary)
(define (write-entry e [word-writer write-word])
  (word-writer (entry-format-code e))
  (word-writer (entry-location e))
  (when (or (equal? (entry-format-code e) ESD)
            (equal? (entry-format-code e) ESR))
        (word-writer (string-length (entry-name e)))
        (for ([c (string->list (entry-name e))])
            (word-writer c))))

; Struct for a complete MERL file
(struct merl (end-module end-code code table) #:mutable #:transparent)

; Read a MERL file from an input port
(define (read-merl [in (current-input-port)])
  (unless (equal? (read-word in) MERL-COOKIE)
        (err "Invalid MERL file (first word of header incorrect)"))
  (define end-module  (read-word in))
  (define end-code  (read-word in))
  (define code  (list->vector (read-words (/ (- end-code HEADER-SIZE) WORD-SIZE) in)))
  (define table (read-entries (/ (- end-module end-code) WORD-SIZE) in))
  (merl end-module end-code code table))

; Write a MERL file to an output port
; Format is specified by passing a one-argument function that prints a word
; (Default format is binary)
(define (write-merl m [word-writer write-word])
  (word-writer MERL-COOKIE)
  (word-writer (merl-end-module m))
  (word-writer (merl-end-code m))
  (for ([word (merl-code m)])
    (word-writer word))
  (for ([e (merl-table m)])
    (write-entry e word-writer)))