; assembler, part 2
(define labels (list))
(define opcodes '(("const" . 0) ("get" . 1) ("put" . 2)
("ld" . 3) ("st" . 4) ("add" . 5) ("sub" . 6)
("jpos" . 7) ("jz" . 8) ("j" . 9) ("halt" . 10)))
(define (split line)
(define (skip-blanks)
(let loop ()
(if (or (null? line) (not (char-whitespace? (car line)))) #f
(begin (set! line (cdr line)) (loop)))))
(define (get-string)
(let loop ((str (list)))
(if (or (null? line) (char-whitespace? (car line)))
(list->string (reverse str))
(let ((c (car line)))
(set! line (cdr line))
(loop (cons c str))))))
(let* ((lbl (get-string)) (_ (skip-blanks))
(opc (get-string)) (_ (skip-blanks))
(obj (get-string)) (_ (skip-blanks)))
(values lbl opc obj (list->string line))))
(define (asm1 file-name) ; first-pass
(set! labels (list))
(with-input-from-file file-name (lambda ()
(let loop ((k 0) (line (read-line)) (lines (list)))
(if (eof-object? line) (reverse lines)
(if (or (string=? line "") (char=? (string-ref line 0) #\#))
(loop k (read-line) lines)
(call-with-values
(lambda () (split (string->list line)))
(lambda (lbl opc obj cmt)
(when (not (string=? lbl ""))
(set! labels (cons (cons lbl k) labels)))
(loop (+ k 1) (read-line)
(cons (vector k lbl opc obj cmt) lines))))))))))
(define (asm2 lines) ; second pass
(let ((mem (make-vector 1000 0)))
(do ((lines lines (cdr lines))) ((null? lines) mem)
(let ((num (vector-ref (car lines) 0))
(opc (vector-ref (car lines) 2))
(obj (vector-ref (car lines) 3)))
(vector-set! mem num (+ (* (cdr (assoc opc opcodes)) 1000)
(if (assoc obj labels) (cdr (assoc obj labels))
(if (not (string=? obj "")) (string->number obj)
0))))))))
(define (sim mem)
(let loop ((pc 0) (acc 0))
(let ((addr (modulo (vector-ref mem pc) 1000))
(code (quotient (vector-ref mem pc) 1000)))
(case code
((1) (loop (+ pc 1) (read))) ; get
((2) (display acc) (newline) (loop (+ pc 1) acc)) ; put
((3) (loop (+ pc 1) (vector-ref mem addr))) ; ld
((4) (vector-set! mem addr acc) (loop (+ pc 1) acc)) ; st
((5) (loop (+ pc 1) (+ acc (vector-ref mem addr)))) ; add
((6) (loop (+ pc 1) (- acc (vector-ref mem addr)))) ; sub
((7) (loop (if (positive? acc) addr (+ pc 1)) acc)) ; jpos
((8) (loop (if (zero? acc) addr (+ pc 1)) acc)) ; jz
((9) (loop addr acc)) ; j
((10) (if #f #f)) ; halt
(else (error 'sim "unrecognized command"))))))
(sim (asm2 (asm1 "program.asm")))