アセンブラ完成

コンピュータシステムの理論と実装８章のシンボルも処理できるアセンブラ
完成しました。
前のプログラムから追加した部分の説明を書いておきます。

プログラムを読み込んだら、最初にラベルの処理をします。

(define (assem-label1 lis n result)
  (cond ((null? lis) (reverse result))
	((char=? (caar lis) #\( )
	 (let ((label (list->string (parse-label (car lis)))))
	   (add-entry! label n)
	   (assem-label1 (cdr lis) n result)))
	(else
	 (assem-label1 (cdr lis) (+ n 1) (cons (car lis) result)))))

;ラベルを処理
(define (assem-label lis)
  (let ((lis2 (remove-come&spa-all (map string->list lis))))
    (assem-label1 lis2 0 '())))

例えば

(aaa)
D=1
(bbb)
A=1

のようなプログラムだと、シンボルテーブルに

((aaa . 0)
 (bbb . 1))

のように登録されます。

次に、A命令でシンボルの処理をする部分を追加しました。

;数字の文字列を数値に変えてからnumber->stringで2進数の文字列を返す
(define (code-@1 nimonics) 
  (number->string 
   (string->number 
    (list->string nimonics)) 2))

(define (code-@2 nimonics)
  (cond ((char-numeric? (car nimonics))
	 (code-@1 nimonics))
	(else                                ;シンボルを解決する
	 (let ((sym (list->string nimonics))) 
	   (if (contains sym)
	       (number->string (get-address sym) 2)
	       (number->string (make-var sym) 2)
	       )
	   ))))

特に、この部分でシンボルの処理をしています。

(if (contains sym)
    (number->string (get-address sym) 2)
    (number->string (make-var sym) 2)
 )

シンボルがテーブルに登録されている場合は、get-addressでシンボルに割り当てられている
アドレスにシンボルを置き換える。

登録されていない場合は、make-varでシンボルにアドレスを割り当てる。

(define (make-var sym) 
  (add-entry! sym var-n)
  (set! var-n (+ var-n 1))
  (- var-n 1))

以下が、全体のプログラムです。

(define symbol-table '())

(define (init-symbol-table)
  (add-entry! "SP" 0)
  (add-entry! "LCL" 1)
  (add-entry! "ARG" 2)
  (add-entry! "THIS" 3)
  (add-entry! "THAT" 4)
  (add-entry! "R0" 0)
  (add-entry! "R1" 1)
  (add-entry! "R2" 2)
  (add-entry! "R3" 3)
  (add-entry! "R4" 4)
  (add-entry! "R5" 5)
  (add-entry! "R6" 6)
  (add-entry! "R7" 7)
  (add-entry! "R8" 8)
  (add-entry! "R9" 9)
  (add-entry! "R10" 10)
  (add-entry! "R11" 11)
  (add-entry! "R12" 12)
  (add-entry! "R13" 13)
  (add-entry! "R14" 14)
  (add-entry! "R15" 15)
  (add-entry! "SCREEN" 16384)
  (add-entry! "KBD" 24576))


(define (add-entry! key val) 
  (set! symbol-table (assoc-set! symbol-table key val)))

(define (contains key) (assoc key symbol-table))

(define (get-address symbol)
  (cdr (assoc symbol symbol-table)))

(define var-n 16)

(define (init)
  (init-symbol-table)
  (set! var-n 16))

;変数にメモリを割り当てる
(define (make-var sym) 
  (add-entry! sym var-n)
  (set! var-n (+ var-n 1))
  (- var-n 1))

;inにアセンブルするプログラムのファイル名
;outにアセンブルした結果を出力するファイル名
;例:(assembler "./test.asm" "./test.hack")
(define (assembler in out)
  (init)
  (out-hack out 
	    (assem 
	     (assem-label (read-asm in)))))

;プログラムをリストに読み込む
(define  (read-asm file)
  (call-with-input-file file
    (lambda (i)
      (let loop ((c (read-line i)) (lis '()))
	(if (eof-object? c)
	    (reverse lis)
	    (loop (read-line i) (cons c lis)))))))

;ファイルに出力する
(define (out-hack file lis)
  (call-with-output-file file
    (lambda (i)
      (for-each (lambda (s) 
		  (if (not (string=? s ""))
		      (begin
			(display s i) 
			(newline i)))) lis))))

(define (assem-label1 lis n result)
  (cond ((null? lis) (reverse result))
	((char=? (caar lis) #\( )
	 (let ((label (list->string (parse-label (car lis)))))
	   (add-entry! label n)
	   (assem-label1 (cdr lis) n result)))
	(else
	 (assem-label1 (cdr lis) (+ n 1) (cons (car lis) result)))))

;ラベルを処理
(define (assem-label lis)
  (let ((lis2 (remove-come&spa-all (map string->list lis))))
    (assem-label1 lis2 0 '())))
 
;;アセンブルする
(define (assem lis)
  (map (lambda (s) (assem1  s)) lis))

;;１行をアセンブルする    
(define (assem1 str)
  (let ((str2 (remove-space
	       (remove-coment str))))
    (if (null? str2)
	""
	(if (char=? (car str2) #\@)
	    (apply string-append (list "0" 
				   (code-@ (parse-@ str2))))
	    (apply string-append (cons "111" (code (parse str2))))))))

;スペースを除去する
(define (remove-space lis)
  (remove (lambda (s) (or (char=? s #\space) (char=? s #\tab))) lis))
;コメントを除去する
(define (remove-coment1 lis result)
  (cond ((null? lis) (reverse result))
	((char=? (car lis) #\/) (reverse result))
	(else
	 (remove-coment1 (cdr lis) (cons (car lis) result)))))

(define (remove-coment lis)
  (remove-coment1 lis '()))

;コメントとスペース除去する
(define (remove-come&spa lis)
  (remove-space (remove-coment lis)))

;プログラム全体からコメントとスペースと空行を除去する
(define (remove-come&spa-all lis)
  (remove null? (map remove-come&spa lis)))

;comp,dist,jumpに分ける
(define (parse str)
  (let* ((dest (parse-dest str))
	 (comp (parse-comp (cadr dest)))
	 (jump (parse-jump (cadr comp))))
    (list (car dest) (car comp) jump)))

;dest,comp,jumpのそれぞれに対応したバイナリコードを返す
(define (code nimonics);parse関数の結果を渡す
  (let ((dest (code-dest (list-ref nimonics 0)))
	(comp (code-comp (list-ref nimonics 1)))
	(jump (code-jump (list-ref nimonics 2))))
    (list comp dest jump)))

(define (parse-@ str) (cdr str))

(define (parse-label str) 
  (remove (lambda (s) (char=? s #\) )) (cdr str)))

;数字の文字列を数値に変えてからnumber->stringで2進数の文字列を返す
(define (code-@1 nimonics) 
  (number->string 
   (string->number 
    (list->string nimonics)) 2))

(define (code-@2 nimonics)
  (cond ((char-numeric? (car nimonics))
	 (code-@1 nimonics))
	(else                                ;シンボルを解決する
	 (let ((sym (list->string nimonics))) 
	   (if (contains sym)
	       (number->string (get-address sym) 2)
	       (number->string (make-var sym) 2)
	       )
	   ))))

(define (code-@ nimonics)
  (let ((s (code-@2 nimonics)))
    
    (string-append
     (list->string
      (make-list (- 15 (string-length s)) #\0));桁が足りない場合0を付加する
     s)
      
    )
)

(define (parse-dest1 str lis)
  (if (char=? #\= (car str))
      (list (reverse lis) (cdr str))
      (parse-dest1 (cdr str) (cons (car str) lis))))

(define (parse-dest str)
  (if (member #\= str)
      (parse-dest1 str '())
      (list (string->list "null") str)))

(define (parse-comp1 str lis)
  (if (or (null? str) (char=? #\; (car str)))
      (list (reverse lis) str)
      (parse-comp1 (cdr str) (cons (car str) lis))))

(define (parse-comp str)
  (parse-comp1 str '()))


(define (parse-jump1 str lis)
  (if (null? str)
      (reverse lis)
      (parse-jump1 (cdr str) (cons (car str) lis))))

(define (parse-jump str)
  (if (or (null? str) (null? (cdr str)))
      (string->list "null")
      (parse-jump1 (cdr str) '())))
      


(define (code-comp nimonic)
  (let1 nimostr (list->string nimonic)
	(cond ((string=? nimostr "D+1") "0011111")
	      ((string=? nimostr "0") "0101010")
	      ((string=? nimostr "1") "0111111")
	      ((string=? nimostr "-1") "0111010")
	      ((string=? nimostr "D") "0001100")
	      ((string=? nimostr "A") "0110000")
	      ((string=? nimostr "M") "1110000")
	      ((string=? nimostr "!D") "0001101")
	      ((string=? nimostr "!A") "0110001")
	      ((string=? nimostr "!M") "1110001")
	      ((string=? nimostr "-D") "0001111")
	      ((string=? nimostr "-A") "0110011")
	      ((string=? nimostr "-M") "1110011")
	      ((string=? nimostr "A+1") "0110111")
	      ((string=? nimostr "M+1") "1110111")
	      ((string=? nimostr "D-1") "0001110")
	      ((string=? nimostr "A-1") "0110010")
	      ((string=? nimostr "M-1") "1110010")
	      ((string=? nimostr "D+A") "0000010")
	      ((string=? nimostr "D+M") "1000010")
	      ((string=? nimostr "D-A") "0010011")
	      ((string=? nimostr "D-M") "1010011")
	      ((string=? nimostr "A-D") "0000111")
	      ((string=? nimostr "M-D") "1000111")
	      ((string=? nimostr "D&A") "0000000")
	      ((string=? nimostr "D&M") "1000000")
	      ((string=? nimostr "D|A") "0010101")
	      ((string=? nimostr "D|M") "1010101")
	      (else (error nimostr))


	      )))


(define (code-dest nimonic)
  (let1 nimostr (list->string nimonic)
	(cond ((string=? nimostr "null") "000")
	      ((string=? nimostr "M") "001")
	      ((string=? nimostr "D") "010")
	      ((string=? nimostr "MD") "011")
	      ((string=? nimostr "A") "100")
	      ((string=? nimostr "AM") "101")
	      ((string=? nimostr "AD") "110")
	      ((string=? nimostr "AMD") "111")
	      (else (error nimostr)))))


(define (code-jump nimonic)
  (let1 nimostr (list->string nimonic)
	(cond ((string=? nimostr "null") "000")
	      ((string=? nimostr "JGT") "001")
	      ((string=? nimostr "JEQ") "010")
	      ((string=? nimostr "JGE") "011")
	      ((string=? nimostr "JLT") "100")
	      ((string=? nimostr "JNE") "101")
	      ((string=? nimostr "JLE") "110")
	      ((string=? nimostr "JMP") "111")
	      (else (error nimostr)))))