Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
261 lines (235 sloc) 9.69 KB
#lang racket/base
(require racket/list
racket/match
file/sha1
racket/path
racket/port)
(define current-labels (make-parameter #f))
(define current-bank (make-parameter #f))
(struct label (actual-address bank references)
#:transparent
#:mutable)
(struct label-reference (use-address use-bank kind)
#:transparent)
; Addresses should be 24 bits
(define HIGH-BITS #xff0000)
(define MIDL-BITS #x00ff00)
(define LOWR-BITS #x0000ff)
(define (hex v) (format "#x~a" (number->string v 16)))
(define (format-addr name addr bank use-addr^ kind)
(match kind
['bank
(bytes bank)]
['long
(bytes (bitwise-bit-field addr 0 8)
(bitwise-bit-field addr 8 16)
(bitwise-bit-field addr 16 24))]
['&
(integer->integer-bytes
(bitwise-and (bitwise-not HIGH-BITS) addr)
2 #f)]
; The two addresses share the first 8 bits
['absolute
(define use-addr (+ use-addr^ 2))
(cond
[(= (bitwise-and addr HIGH-BITS)
(bitwise-and use-addr HIGH-BITS))
(integer->integer-bytes
(bitwise-and (bitwise-not HIGH-BITS) addr)
2 #f)]
[else
(error
'format-addr
"Absolute addr references do not share upper 8-bits: addr(~a:~a)[~a] and use(~a)[~a]"
name
(hex addr) (hex (bitwise-and addr HIGH-BITS))
(hex use-addr) (hex (bitwise-and use-addr HIGH-BITS)))])]
; The two addresses are within 128 bytes
['relative
(define use-addr (+ use-addr^ 1))
(define diff (- addr use-addr))
(cond
[(= 0 diff)
(bytes diff)]
[(< 0 diff (add1 128))
(bytes diff)]
[(< (sub1 -128) diff 0)
(bytes (modulo diff 256))]
[else
(error 'format-addr
"Distance too far for relative addr: addr(~a:~a) from use(~a)"
name (hex addr) (hex use-addr))])]
[x
(error 'format-addr "Can't format addr(~a:~a) to ~e from use(~a)"
name (hex addr) x (hex use-addr^))]))
(define (label-lookup! the-label use-addr kind)
(match-define
(and l (label actual bank refs))
(hash-ref! (current-labels) the-label
(λ () (label #f #f empty))))
(set-label-references! l
(list* (label-reference use-addr (current-bank) kind)
refs))
(format-addr the-label 0 0 0 kind))
(define (label-define! the-label actual-addr)
(match
(hash-ref! (current-labels) the-label
(λ () (label #f #f empty)))
[(and l (label #f #f refs))
(set-label-actual-address! l actual-addr)
(set-label-bank! l (current-bank))]
[_
(error 'label-define!
"Label ~e has already been defined"
the-label)]))
(struct label-use (name kind))
(define (write-label-use label kind)
(define addr
(label-lookup! (label-use-name label)
(current-address)
kind))
(write-bytes addr))
(define (current-address)
(file-position (current-output-port)))
(define (write-bytes@ out pos bs)
(file-position out pos)
(write-bytes bs out))
(define (read-byte@ in pos)
(file-position in pos)
(read-byte in))
(define (16bit+ x y)
(modulo (+ x y) (expt 2 16)))
(define current-debug (make-parameter #f))
(define (debug-opcode src)
(fprintf (current-debug) "~a\t~a\n" (hex (current-address)) src))
(define (compile-rom pth rl)
(rl pth))
(define (make-rom #:slot-start slot-start
#:rom-bank-size rom-bank-size
#:rom-banks rom-banks
#:id id ; XXX 1-4 letter string
#:name name ; XXX 21 bytes, exactly
#:slow-rom? slow-rom?
#:lo-rom? lo-rom?
#:cartridge-type cartridge-type
#:rom-size rom-size
#:sram-size sram-size
#:native-interrupts native-interrupt->label
#:emulation-interrupts emulation-interrupt->label
. banks)
;; fill unused areas with #x00, opcode for BRK.
;; BRK will crash the snes if executed.
(define empty-fill #x00)
;; USA
(define country-code #x01)
(define license-code #x00)
(define version #x00)
(lambda (pth)
(define total-rom-size
(* rom-bank-size
rom-banks))
(define bank->start (make-hasheq))
(for ([bank (in-range rom-banks)])
(hash-set! bank->start bank (* bank rom-bank-size)))
(define header-start (if lo-rom? #x7F00 #xFF00))
(define labels (make-hasheq))
(call-with-output-file pth
#:mode 'binary #:exists 'replace
(λ (out)
;; Empty fill
(for ([i (in-range total-rom-size)])
(write-byte empty-fill out))
;; Write header
;; XXX look at http://patpend.net/technical/snes/sneskart.html#embededcartridge
(write-bytes@ out (+ header-start #xB2) id)
(write-bytes@ out (+ header-start #xC0) name)
(write-bytes@ out (+ header-start #xD5) (bytes (if slow-rom? #x20 #x00)))
(write-bytes@ out (+ header-start #xD6) (bytes cartridge-type))
(write-bytes@ out (+ header-start #xD7) (bytes rom-size))
(write-bytes@ out (+ header-start #xD8) (bytes sram-size))
(write-bytes@ out (+ header-start #xD9) (bytes country-code))
(write-bytes@ out (+ header-start #xDA) (bytes license-code))
(write-bytes@ out (+ header-start #xDB) (bytes version))
(parameterize ([current-labels labels]
[current-bank 0]
[current-output-port out])
;; Write interrupt tables for native mode
(file-position out (+ header-start #xE4))
(write-label-use (hash-ref native-interrupt->label 'COP) '&)
(write-label-use (hash-ref native-interrupt->label 'BRK) '&)
(write-label-use (hash-ref native-interrupt->label 'ABORT) '&)
(write-label-use (hash-ref native-interrupt->label 'NMI) '&)
(write-bytes (bytes #x00 #x00) out)
(write-label-use (hash-ref native-interrupt->label 'IRQ) '&)
;; Write interrupt tables for emulation mode
(file-position out (+ header-start #xF4))
(write-label-use (hash-ref emulation-interrupt->label 'COP) '&)
(write-bytes (bytes #x00 #x00) out)
(write-label-use (hash-ref emulation-interrupt->label 'ABORT) '&)
(write-label-use (hash-ref emulation-interrupt->label 'NMI) '&)
(write-label-use (hash-ref emulation-interrupt->label 'RESET) '&)
(write-label-use (hash-ref emulation-interrupt->label 'IRQBRK) '&)
;; Write sections
(call-with-output-file
(format "~a.debug" pth) #:exists 'replace
(lambda (dout)
(parameterize ([current-debug dout])
(for ([sections (in-list banks)]
[bank (in-naturals)])
(for ([thunk (in-list sections)])
(define bank-start (hash-ref bank->start bank))
(file-position out bank-start)
(parameterize ([current-bank bank])
(thunk))
(hash-set! bank->start bank (current-address))
(eprintf "Wrote a section from ~a to ~a in bank ~a\n"
(hex bank-start) (hex (current-address)) bank))))))
;; Rewrite labels
(for ([(label-name l) (in-hash labels)])
(match-define (label label-addr label-bank refs) l)
(unless label-addr
(error 'compile
"Label ~e was never defined"
label-name))
(define label-addr^ (+ (* (add1 label-bank) slot-start) label-addr))
(for ([r (in-list refs)])
(match-define (label-reference use-addr use-bank kind) r)
(define use-addr^ (+ (* (add1 use-bank) slot-start) use-addr))
(define written-addr (format-addr label-name label-addr^ label-bank use-addr^ kind))
(eprintf "Rewrote ~a/~a to use ~a (the ~a form of ~a/~a which is called ~a)\n"
(hex use-addr) (hex use-addr^)
(bytes->hex-string written-addr)
kind
(hex label-addr) (hex label-addr^)
label-name)
(write-bytes@ out use-addr written-addr))))))
;; Discover the checksum (copied from WLALINK, compute.c)
(define-values
(inverse-checksum checksum)
(call-with-input-file pth
#:mode 'binary
(λ (in)
(define n #f)
(define m #f)
(if (total-rom-size . < . (* 512 1024))
(begin (set! n total-rom-size)
(set! m 0))
(error 'xxx))
(define x 0)
(for ([i (in-range 0 n)])
(if lo-rom?
(unless (<= #x7FDC i #x7FDF)
(set! x (16bit+ x (read-byte@ in i))))
(unless (<= #xFFDC i #xFFDF)
(set! x (16bit+ x (read-byte@ in i))))))
(set! x (16bit+ x (* 2 255)))
(define l (bitwise-xor (bitwise-and x #xFFFF) #xFFFF))
(values l x))))
;; Write the checksum
(call-with-output-file pth
#:mode 'binary #:exists 'update
(λ (out)
(write-bytes@ out (+ header-start #xDC)
(bytes-append (integer->integer-bytes inverse-checksum 2 #f)
(integer->integer-bytes checksum 2 #f)))))))
(provide (all-defined-out))