|
#lang racket/base |
|
|
|
;;; Solution to |
|
;;; http://programmingpraxis.com/2014/04/15/assembler-part-1 |
|
;;; |
|
;;; adolfo.pa@gmail.com |
|
|
|
(require racket/dict |
|
racket/match |
|
racket/sequence |
|
racket/set |
|
racket/string) |
|
|
|
(module+ test |
|
(require rackunit)) |
|
|
|
(define instructions |
|
(hash "const" 00 |
|
"get" 01 |
|
"put" 02 |
|
"ld" 03 |
|
"st" 04 |
|
"add" 05 |
|
"sub" 06 |
|
"jpos" 07 |
|
"jz" 08 |
|
"j" 09 |
|
"halt" 10)) |
|
|
|
(define instr-regexp |
|
(string-join (map regexp-quote |
|
(sort (hash-keys instructions) > #:key string-length)) |
|
"|" |
|
#:before-first "(" |
|
#:after-last ")")) |
|
|
|
(define stmt-regexp |
|
(pregexp |
|
(string-append "[ \t]*" ; leading whitespace |
|
"(?:" ; (1) |
|
"(?:(\\w+)[ \t]+)??" ; optional label |
|
instr-regexp ; instruction mnemonic |
|
"(?:[ \t]+(\\d+|\\w+))?" ; optional argument |
|
")?" ; (1) |
|
"(?:#.*)?"))) ; optional comment |
|
|
|
(struct stmt (label op arg) #:transparent) |
|
|
|
(define (read-stmt line) |
|
(match (regexp-match stmt-regexp line) |
|
[(list _ fst snd thd) |
|
(when (and snd (not (dict-ref instructions snd #f))) |
|
(error "syntax error: unknown mnemonic" line)) |
|
(and (or fst snd thd) |
|
(stmt fst snd thd))] |
|
[#f |
|
(error "syntax error: ill formed statement" line)])) |
|
|
|
(module+ test |
|
;; instruction, argument and comment |
|
(check-equal? (read-stmt "ld zero # initialize sum to zero") |
|
(stmt #f "ld" "zero")) |
|
;; instruction and argument |
|
(check-equal? (read-stmt "st sum") |
|
(stmt #f "st" "sum")) |
|
;; lone instruction |
|
(check-equal? (read-stmt "get") (stmt #f "get" #f)) |
|
;; label, instruction, argument and comment |
|
(check-equal? (read-stmt "done ld sum # print sum") |
|
(stmt "done" "ld" "sum")) |
|
;; label, instruction and comment |
|
(check-equal? (read-stmt "loop get # read a number") |
|
(stmt "loop" "get" #f)) |
|
;; lone comment |
|
(check-equal? (read-stmt "# foo") #f) |
|
;; empty statement |
|
(check-equal? (read-stmt "") #f)) |
|
|
|
(define (read-asm in) |
|
(for*/list ([line (in-lines in)] |
|
[st (in-value (read-stmt line))] |
|
#:when st) |
|
st)) |
|
|
|
(module+ test |
|
(define program #<<EOS |
|
# print sum of input numbers (terminated by zero) |
|
|
|
ld zero # initialize sum to zero |
|
st sum |
|
loop get # read a number |
|
jz done # no more input if number is zero |
|
add sum # add input to accumulated sum |
|
st sum # store new value back in sum |
|
j loop # go back and read another number |
|
|
|
done ld sum # print sum |
|
put |
|
halt |
|
|
|
zero const 0 |
|
sum const |
|
EOS |
|
) |
|
|
|
(check-equal? (read-asm (open-input-string program)) |
|
(list (stmt #f "ld" "zero") |
|
(stmt #f "st" "sum") |
|
(stmt "loop" "get" #f) |
|
(stmt #f "jz" "done") |
|
(stmt #f "add" "sum") |
|
(stmt #f "st" "sum") |
|
(stmt #f "j" "loop") |
|
(stmt "done" "ld" "sum") |
|
(stmt #f "put" #f) |
|
(stmt #f "halt" #f) |
|
(stmt "zero" "const" "0") |
|
(stmt "sum" "const" #f)))) |
|
|
|
(define (make-symbol-table xs) |
|
(for/hash ([x xs] |
|
[n (in-naturals)] |
|
#:when (stmt-label x)) |
|
(values (stmt-label x) n))) |
|
|
|
(module+ test |
|
(let ([labels |
|
(make-symbol-table |
|
(read-asm |
|
(open-input-string program)))]) |
|
(check-equal? labels (hash "loop" 2 |
|
"done" 7 |
|
"zero" 10 |
|
"sum" 11)))) |
|
|
|
(define (resolve arg labels) |
|
(cond [(not arg) 0] |
|
[(regexp-match #px"^\\d+$" arg) |
|
(string->number arg)] |
|
[else |
|
(dict-ref labels arg)])) |
|
|
|
(define (encode op arg labels) |
|
(+ (* (dict-ref instructions op) 1000) |
|
(if arg (resolve arg labels) 0))) |
|
|
|
(define (assemble prog [mem (make-vector 1000 0)]) |
|
(define stmts (read-asm prog)) |
|
(define labels |
|
(make-symbol-table stmts)) |
|
(for ([x stmts] |
|
[i (in-naturals)]) |
|
(match x |
|
[(stmt _ "const" arg) |
|
(vector-set! mem i (resolve arg labels))] |
|
[(stmt _ op arg) |
|
(vector-set! mem i (encode op arg labels))])) |
|
mem) |
