CASL II Assembler

casl.clj

(ns casl-assembler
  (:use [clojure.test :only (deftest is run-tests)]
        [clojure.contrib.str-utils :only (re-split)]))

(def prog0
     [
      "PROG1 START GO"
      "DATA1 DC    1"
      "DATA2 DC    2"
      "ANS   DS    1"
      "GO    LD    GR0,DATA1"
      "      ADDA  GR0,DATA2"
      "      ST    GR0,ANS"
      "      END"]
     )

(comment
  "
方針
1.コメントを削除する
2.ラベルの値を決定する
　2.1 行をラベルとオペレータに分割する
　　2.1.1 ラベルがあった場合は、現在のメモリカウンタをラベルと対応付ける
　　2.1.2 オペレータを元にメモリカウンタを増加する

3.オペレータをコードに変換する
　3.1 行からオペレータを取り出す
　3.2 オペレータをオペコードとオペランドに分割する
　　3.2.1 オペコードに対応した処理に、オペランドとラベルテーブルを渡し、マシンコードを得る
"
  )

(defn third [x]
  (first (next (next x))))

(deftest test-third
  (is (= nil (third nil)))
  (is (= "3rd" (third '("1st" "2nd" "3rd"))))
  (is (= nil (third '("1st" "2nd")))))

(def registers {"GR0" 0 "GR1" 1 "GR2" 2 "GR3" 3 "GR4" 4 "GR5" 5 "GR6" 6 "GR7" 7})

(defn register-name? [str]
  (not (nil? (registers str))))

(deftest test-register-name?
  (is (= false (register-name? "GR8")))
  (is (= true  (register-name? "GR0")))
  (is (= true  (register-name? "GR1")))
  (is (= true  (register-name? "GR2")))
  (is (= true  (register-name? "GR3")))
  (is (= true  (register-name? "GR4")))
  (is (= true  (register-name? "GR5")))
  (is (= true  (register-name? "GR6")))
  (is (= true  (register-name? "GR7"))))

(defn remove-comment [asm-line]
  (.trim (re-find #"^[^;]*" asm-line)))

(deftest test-remove-comment
  (is (thrown? NullPointerException (remove-comment nil)))
  (is (= ""                         (remove-comment "")))
  (is (= ""                         (remove-comment " ")))
  (is (= ""                         (remove-comment ";comment")))
  (is (= "OPCODE OPERAND"           (remove-comment " OPCODE OPERAND;comment"))))

(defn label-and-operator [asm-line]
  (rest (re-find #"^(\w*)\s+(.*)" asm-line)))

(deftest test-label-and-operator
  (is (thrown? NullPointerException   (label-and-operator nil)))
  (is (= '("LABEL" "OPECODE OPERAND") (label-and-operator "LABEL OPECODE OPERAND")))
  (is (= '("" "OPECODE OPERAND")      (label-and-operator " OPECODE OPERAND"))))

(defn opcode-and-operand [operator]
  (let [splits (re-split #"\s+" operator)]
    (if (= (count splits) 1) (cons (first splits) '(nil)) splits)))

(deftest test-opcode-and-orerand
  (is (thrown? NullPointerException (opcode-and-operand nil)))
  (is (= '("" nil)                  (opcode-and-operand "")))
  (is (= '("" "OPERAND")            (opcode-and-operand " OPERAND")))
  (is (= '("OPCODE" "OPERAND")      (opcode-and-operand "OPCODE OPERAND"))))

(defn split-operand [operand]
  (if (nil? operand) nil
      (re-split #"[\s,]+" operand)))

(deftest test-split-operand
  (is (= nil               (split-operand nil)))
  (is (= '("r1" "r2"))     (split-operand "r1,r2"))
  (is (= '("r" "adr" "x")) (split-operand "r,adr,x"))
  (is (= '("r"))           (split-operand "r")))

(defn r1-r2? [operand-coll]
  (if (and (= (count operand-coll) 2)
           (register-name? (first operand-coll))
           (register-name? (second operand-coll)))
    true
    false))

(deftest test-r1-r2?
  (is (= false (r1-r2? nil)))
  (is (= true (r1-r2? '("GR0" "GR1"))))
  (is (= false (r1-r2? '("GR8" "GR1"))))
  (is (= false (r1-r2? '("GR1" "ADR"))))
  (is (= false (r1-r2? '("GR1" "GR2" "GR3"))))
  (is (= false (r1-r2? '("GR1" "ADR" "GR3")))))

(defn r-adr? [operand-coll]
  (if (and (= (count operand-coll) 2)
           (register-name? (first operand-coll))
           (not (register-name? (second operand-coll))))
    true
    false))

(deftest test-r-adr?
  (is (= false (r-adr? nil)))
  (is (= false (r-adr? '("GR0" "GR1"))))
  (is (= false (r-adr? '("GR8" "GR1"))))
  (is (= true  (r-adr? '("GR1" "ADR"))))
  (is (= false (r-adr? '("GR1" "GR2" "GR3"))))
  (is (= false (r-adr? '("GR1" "ADR" "GR3")))))

(defn r-adr-x? [operand-coll]
  (if (and (= (count operand-coll) 3)
           (register-name? (first operand-coll))
           (not (register-name? (second operand-coll)))
           (register-name? (third operand-coll)))
    true
    false))

(deftest test-r-adr-x?
  (is (= false (r-adr-x? nil)))
  (is (= false (r-adr-x? '("GR0" "GR1"))))
  (is (= false (r-adr-x? '("GR8" "GR1"))))
  (is (= false (r-adr-x? '("GR1" "ADR"))))
  (is (= false (r-adr-x? '("GR1" "GR2" "GR3"))))
  (is (= true  (r-adr-x? '("GR1" "ADR" "GR3")))))

(defn adr-x? [operand-coll]
  (if (and (= (count operand-coll) 2)
           (not (register-name? (first operand-coll)))
           (register-name? (second operand-coll)))
    true
    false))

(deftest test-adr-x?
  (is (= false (adr-x? nil)))
  (is (= false (adr-x? '("GR0" "GR1"))))
  (is (= true  (adr-x? '("ADR" "GR1"))))
  (is (= false (adr-x? '("GR1" "ADR"))))
  (is (= false (adr-x? '("GR1" "GR2" "GR3"))))
  (is (= false (adr-x? '("GR1" "ADR" "GR3")))))

(defn r? [operand-coll]
  (if (and (= (count operand-coll) 1)
           (register-name? (first operand-coll)))
    true
    false))

(deftest test-r?
  (is (= false (r? nil)))
  (is (= true  (r? '("GR1"))))
  (is (= false (r? '("GR0" "GR1"))))
  (is (= false (r? '("ADR" "GR1"))))
  (is (= false (r? '("GR1" "ADR"))))
  (is (= false (r? '("GR1" "GR2" "GR3"))))
  (is (= false (r? '("GR1" "ADR" "GR3")))))

(defn get-adr [adr-str label-table]
  (if (nil? (label-table adr-str)) (Integer/parseInt adr-str)
      (label-table adr-str)))

(deftest test-get-adr
  (is (thrown? NumberFormatException (get-adr nil {})))
  (is (= 42  (get-adr "42" {})))
  (is (= 42  (get-adr "ANSWER" {"ANSWER" 42}))))

(defn get-operand-code-1-word [oprs opcode-word]
  (cond (nil? oprs) 0x0000
        (r? oprs) (bit-or opcode-word (bit-shift-left (registers (first oprs)) 4)) 
        (r1-r2? oprs) (bit-or opcode-word (bit-or (bit-shift-left (registers (first oprs)) 4)
                                                  (registers (second oprs))))
        :else (throw (java.lang.IllegalArgumentException))))

(defn get-operand-code-2-words [oprs label-table opcode-word]
  (cond (r-adr? oprs) (list
                       (bit-or opcode-word
                               (bit-shift-left (registers (first oprs)) 4))
                       (get-adr (second oprs) label-table))
        (r-adr-x? oprs) (list
                         (bit-or opcode-word (bit-or (bit-shift-left (registers (first oprs)) 4)
                                                     (registers (third oprs))))
                         (get-adr (second oprs) label-table))
        :else (throw (java.lang.IllegalArgumentException))))



(defn string->code [str]
  (let [[_ string] (re-find #"^'(.*)'$" str)]
    (loop [seq-string (seq string) out '()]
      (if (empty? seq-string) (reverse out) 
          (let [fst (first seq-string)]
            (recur
             (if (= fst \') (rest (rest seq-string)) (rest seq-string))
             (cons (int fst) out)))))))

(deftest test-string->code
  (is (thrown? Exception (string->code nil)))
  (is (= '() (string->code "")))
  (is (= '(65 66 67) (string->code "'ABC'"))))

(defn get-dc-code [oprs label-table]
  (cond (not (nil? (re-find #"^[0-9].*" (first oprs)))) (Integer/parseInt (first oprs))
        (not (nil? (re-find #"^#(.*)" (first oprs))))
        (let [[_ val] (re-find #"^#(.*)" (first oprs))] (Integer/parseInt val 16)) 
        (not (nil? (re-find #"^'.*" (first oprs)))) (string->code (first oprs))
        :else (get-adr label-table)))

(defn get-code [operator label-table]
  (let [[opcode operand] (opcode-and-operand operator)
        oprs (split-operand operand)]
    (case opcode
          "NOP" '(0x0000)
          "LD" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x1000)
                     (r1-r2? oprs) (get-operand-code-1-word oprs 0x1400)
                     :else (throw (java.lang.IllegalArgumentException)))
          "ST" (get-operand-code-2-words oprs label-table 0x1100)
          "LAD" (get-operand-code-2-words oprs label-table 0x1200)
          "ADDA" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x2000)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x2400))
          "SUBA" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x2100)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x2500))
          "ADDL" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x2200)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x2600))
          "SUBL" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x2300)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x2700))
          "AND" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x3000)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x3400))
          "OR" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x3100)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x3500))
          "XOR" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x3200)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x3600))
          "CPA" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x4000)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x4400))
          "CPL" (cond (or (r-adr? oprs) (r-adr-x? oprs)) (get-operand-code-2-words oprs label-table 0x4100)
                       (r1-r2? oprs) (get-operand-code-1-word oprs 0x4500))
          "SLA" (get-operand-code-2-words oprs label-table 0x5000)
          "SRA" (get-operand-code-2-words oprs label-table 0x5100)
          "SLL" (get-operand-code-2-words oprs label-table 0x5200)
          "SRL" (get-operand-code-2-words oprs label-table 0x5300)
          "JMI" (get-operand-code-2-words oprs label-table 0x6100)
          "JNZ" (get-operand-code-2-words oprs label-table 0x6200)
          "JZE" (get-operand-code-2-words oprs label-table 0x6300)
          "JUMP" (get-operand-code-2-words oprs label-table 0x6400)
          "JPL" (get-operand-code-2-words oprs label-table 0x6500)
          "JOV" (get-operand-code-2-words oprs label-table 0x6600)
          "PUSH" (get-operand-code-2-words oprs label-table 0x7000)
          "POP" (get-operand-code-1-word oprs 0x7100)
          "CALL" (get-operand-code-2-words oprs label-table 0x8000)
          "RET" 0x8100
          "SVC" (get-operand-code-2-words oprs label-table 0xF000)
          "START" nil
          "END" nil
          "DC" 1
          "DS" (for [x (range 0 (Integer/parseInt (first oprs)))] 0x0000)
          :else (throw (java.lang.IllegalArgumentException (str "ERROR:" opcode)))
)))

(defn count-codesize [operator]
  (let [[opcode operand] (opcode-and-operand operator)
        oprs (split-operand operand)]
    (case opcode
          "NOP" 1
          "LD" (cond (r-adr? oprs) 2
                     (r-adr-x? oprs)2
                     (r1-r2? oprs) 1
                     :else (throw (java.lang.IllegalArgumentException.
                                   (str "ERROR:" operator)))) 
          "ST" 2
          "LAD" 2
          "ADDA" (cond (r-adr? oprs) 2
                       (r-adr-x? oprs) 2
                       (r1-r2? oprs) 1
                       :else (throw (java.lang.IllegalArgumentException.
                                     (str "ERROR:" operator))))
          "SUBA" (cond (r-adr? oprs) 2
                       (r-adr-x? oprs) 2
                       (r1-r2? oprs) 1
                       :else (throw (java.lang.IllegalArgumentException.
                                     (str "ERROR:" operator))))
          "ADDL" (cond (r-adr? oprs) 2
                       (r-adr-x? oprs) 2
                       (r1-r2? oprs) 1
                       :else (throw (java.lang.IllegalArgumentException.
                                     (str "ERROR:" operator))))
          "SUBL" (cond (r-adr? oprs) 2
                       (r-adr-x? oprs) 2
                       (r1-r2? oprs) 1
                       :else (throw (java.lang.IllegalArgumentException.
                                     (str "ERROR:" operator))))
          "AND" (cond (r-adr? oprs) 2
                      (r-adr-x? oprs) 2
                      (r1-r2? oprs) 1
                      :else (throw (java.lang.IllegalArgumentException.
                                    (str "ERROR:" operator))))
          "OR" (cond (r-adr? oprs) 2
                     (r-adr-x? oprs) 2
                     (r1-r2? oprs) 1
                     :else (throw (java.lang.IllegalArgumentException.
                                   (str "ERROR:" operator))))
          "XOR" (cond (r-adr? oprs) 2
                      (r-adr-x? oprs) 2
                      (r1-r2? oprs) 1
                      :else (throw (java.lang.IllegalArgumentException.
                                    (str "ERROR:" operator))))
          "CPA" (cond (r-adr? oprs) 2
                      (r-adr-x? oprs) 2
                      (r1-r2? oprs) 1
                      :else (throw (java.lang.IllegalArgumentException.
                                    (str "ERROR:" operator))))
          "CPL" (cond (r-adr? oprs) 2
                      (r-adr-x? oprs) 2
                      (r1-r2? oprs) 1
                      :else (throw (java.lang.IllegalArgumentException.
                                    (str "ERROR:" operator))))
          "SLA" 2
          "SRA" 2
          "SLL" 2
          "SRL" 2
          "JMI" 2
          "JNZ" 2
          "JZE" 2
          "JUMP" 2
          "JPL" 2
          "JOV" 2
          "PUSH" 2
          "POP" 1
          "CALL" 2
          "RET" 1
          "SVC" 2
          "START" 0
          "END" 0
          "DC" (count (string->code (first oprs)))
          "DS" (Integer/parseInt (first oprs))
)))


(defn update-label-table [label adr table]
  (if (not= label "") (merge {label adr} table) table))

(defn calc-counter [label-operator address-counter label-table]
  (let [[label operator] (label-and-operator label-operator)]
    (list (+ address-counter (count-codesize operator))
          (update-label-table label address-counter label-table))))

(defn make-label-table [list-of-asm]
  (loop [current-line (first list-of-asm)
         rest-lines (rest list-of-asm)
         adr 0
         label-table {}]
    (if (nil? current-line) (list adr label-table)
        (let [[new-adr new-table] (calc-counter current-line adr label-table)]
          (recur (first rest-lines) (rest rest-lines) new-adr new-table)))))

(defn get-machine-code [label-operator label-table]
  (let [[label operator] (label-and-operator label-operator)]
    (get-code operator label-table)))

(defn make-machine-code [list-of-asm label-table]
  (loop [current-line (first list-of-asm)
         rest-lines (rest list-of-asm)
         machine-code []]
    (if (nil? current-line) machine-code
        (recur (first rest-lines)
               (rest rest-lines)
               (conj machine-code (get-machine-code current-line label-table))))))

(defn asm [program]
  (remove nil? (flatten (make-machine-code program (second (make-label-table program))))))

(defn print-hex [coll]
  (for [c coll] (format "%04x" c)))