Solution to http://programmingpraxis.com/2014/04/15/assembler-part-1

asm-1-notests.rkt

#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)

(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)]))

(define (read-asm in)
  (for*/list ([line (in-lines in)]
              [st (in-value (read-stmt line))]
              #:when st)
    st))

(define (make-symbol-table xs)
  (for/hash ([x xs]
             [n (in-naturals)]
             #:when (stmt-label x))
    (values (stmt-label x) n)))

(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)

asm-1.rkt

#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)