7章のVM変換器完成

コンピュータシステムの理論と実装７章のVM変換器完成しました。
vmtranslator関数に.vmファイルか、.vmファイルのあるフォルダの
パスの文字列を渡せば、asmファイルに変換されます。

(use file.util)

(define (read-vfile 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 (vmtranslator1 path)
  (vm-file-name-set! path)
  (let1 lis (read-vfile path)
	(apply string-append 
	       (map translator lis))))


(define (translator str)
  (let1 command (parse (string->list str))
	(cond ((null? command) "")
	      ((equal? command '("add")) vm-add)
	      ((equal? command '("sub")) vm-sub)
	      ((equal? command '("neg")) vm-neg)
	      ((equal? command '("eq")) (vm-eq))
	      ((equal? command '("gt")) (vm-gt))
	      ((equal? command '("lt")) (vm-lt))
	      ((equal? command '("and")) vm-and)
	      ((equal? command '("or")) vm-or)
	      ((equal? command '("not")) vm-not)

	      ((vm-push-constant? command)
	       (push_constant (string->number (caddr command))))

	      ((vm-pop-local? command)
	       (vm-pop_ "LCL" (string->number (caddr command))))
	      ((vm-pop-argument? command)
	       (vm-pop_ "ARG" (string->number (caddr command))))
	      ((vm-pop-this? command)
	       (vm-pop_ "THIS" (string->number (caddr command))))
	      ((vm-pop-that? command)
	       (vm-pop_ "THAT" (string->number (caddr command))))
	      ((vm-pop-temp? command)
	       (vm-pop-temp (string->number (caddr command))))
	      ((vm-pop-pointer? command)
	       (vm-pop-pointer (string->number (caddr command))))
	      ((vm-pop-static? command)
	       (vm-pop-static (caddr command) vm-file-name))

	      ((vm-push-local? command)
	       (vm-push_ "LCL" (caddr command)))
	      ((vm-push-argument? command)
	       (vm-push_ "ARG" (caddr command)))
	      ((vm-push-this? command)
	       (vm-push_ "THIS" (caddr command)))
	      ((vm-push-that? command)
	       (vm-push_ "THAT" (caddr command)))
	      ((vm-push-temp? command)
	       (vm-push-temp (string->number (caddr command))))
	      ((vm-push-pointer? command)
	       (vm-push-pointer (string->number (caddr command))))
	      ((vm-push-static? command)
	       (vm-push-static (caddr command) vm-file-name))

	      (else (error str))
	      )))
(define (vmtranslator path)
  (cond ((and (path-extension path) (string=? (path-extension path) "vm"))
	 (call-with-output-file (path-swap-extension path "asm")
				(lambda (p)
				  (display (string-append
					     "@start\n"
					     "0;JMP\n"
					     vm-true
					     vm-false
					     "(start)\n"
					     (vmtranslator1 path) )
					   p))))
	(else 
	  (let1 file-list (remove  (lambda (s) (not (and (path-extension s) 
							 (string=? (path-extension s) "vm")))) 
				   (sys-readdir path))
		(call-with-output-file (path-swap-extension path "asm")
				       (lambda (p) 
					 (display (string-append
						    "@start\n"
						    "0;JMP\n"
						    vm-true
						    vm-false
						    "(start)\n")
						  p)
					 (for-each (lambda (s) 
						     (display 
						       (vmtranslator1 (string-append path "/" s)) 
						       p))
						   file-list)))))



	))
	 
(define (vm-push-constant? lst)
  (and (string=? (car lst) "push")
       (string=? (cadr lst) "constant")
       ((string->regexp "^\\d+$") (caddr lst))))

(define (vm-pop?-make sym)   
  (lambda (s)
    (and (string=? (car s) "pop")
	 (string=? (cadr s) sym)
	 ((string->regexp "\\d+$") (caddr s)))))

(define vm-pop-local? (vm-pop?-make "local"))
(define vm-pop-argument? (vm-pop?-make "argument"))
(define vm-pop-this? (vm-pop?-make "this"))
(define vm-pop-that? (vm-pop?-make "that"))
(define vm-pop-temp? (vm-pop?-make "temp"))
(define vm-pop-pointer? (vm-pop?-make "pointer"))
(define vm-pop-static? (vm-pop?-make "static"))

(define (vm-push?-make sym)   
  (lambda (s)
    (and (string=? (car s) "push")
	 (string=? (cadr s) sym)
	 ((string->regexp "\\d+$") (caddr s)))))

(define vm-push-local? (vm-push?-make "local"))
(define vm-push-argument? (vm-push?-make "argument"))
(define vm-push-this? (vm-push?-make "this"))
(define vm-push-that? (vm-push?-make "that"))
(define vm-push-temp? (vm-push?-make "temp"))
(define vm-push-pointer? (vm-push?-make "pointer"))
(define vm-push-static? (vm-push?-make "static"))


(define (skip-space str)
  (cond ((null? str) str) 
    	((or  (char=? (car str) #\space) (char=? (car str) #\tab))
      	 (skip-space (cdr str)))
	(else str)))


(define (parse1 str lis s)
  (cond
    ((null? str) (reverse 
		   (cons (list->string (reverse s)) lis)))
    ((or (char=? (car str) #\space) (char=? (car str) #\tab))
	 (parse1 (skip-space str) (cons (list->string (reverse s)) lis) '()))
    (else
      (parse1 (cdr str) lis (cons (car str) s)) 
	  

	)))

(define (parse str)
  (remove (lambda (a) (string=? a ""))
   	  (parse1 (skip-space (remove-coment str))'() '())))

;コメントを除去する
(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 t-f-label-n 0)


(define (count)
  (set! t-f-label-n (+ t-f-label-n 1)))

(define (t-f-label)
  (let1 label (string-append "$" (number->string t-f-label-n))
	(count)
	label))

(define (push_constant n)
  (string-append "@" (number->string n)
		 "\nD=A"
		 "\n@SP"
		 "\nA=M"
		 "\nM=D"
		 "\n@SP"
		 "\nM=M+1\n"))
(define (vm-pop_ sym n)
  (string-append "@" (number->string n) "\n"
		 "D=A\n"
		 "@" sym "\n"
		 "D=M+D\n"
		 "@R13\n"
		 "M=D\n" ;r13にベースアドレス+nを保存
		 "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"

		 "@R13\n"
		 "A=M\n"
		 "M=D\n"))

(define (vm-push_ sym n)
  (string-append "@"  n "\n"
		 "D=A\n"
		 "@" sym "\n"
		 "A=M+D\n"
		 "D=M\n"
		 "@SP\n"
		 "A=M\n"
		 "M=D\n"
		 "D=A\n"
		 "@SP\n"
		 "M=D+1\n"))

(define (vm-pop-temp i)
  (if (or (< i 0) (> i 7))
    (error "pop temp i のiの値は0から7までです。")
    (string-append "@SP\n"
		   "M=M-1\n"
		   "A=M\n"
		   "D=M\n"
		   "@" (number->string (+ 5 i)) "\n"
		   "M=D\n")))

(define (vm-push-temp i)
  (if (or (< i 0) (> i 7))
    (error "push temp i のiの値は0から7までです。")
    (string-append "@" (number->string (+ 5 i)) "\n"
		   "D=M\n"
		   "@SP\n"
		   "A=M\n"
		   "M=D\n"
		   "@SP\n"
		   "M=M+1\n")))

(define (vm-pop-pointer i)
  (if (or (< i 0) (> i 1))
    (error "pop pointer i のiの値は0から1までです。")
    (string-append "@SP\n"
		   "M=M-1\n"
		   "A=M\n"
		   "D=M\n"
		   "@" (number->string (+ 3 i)) "\n"
		   "M=D\n")))

(define (vm-push-pointer i)
  (if (or (< i 0) (> i 1))
    (error "push temp i のiの値は0から1までです。")
    (string-append "@" (number->string (+ 3 i)) "\n"
		   "D=M\n"
		   "@SP\n"
		   "A=M\n"
		   "M=D\n"
		   "@SP\n"
		   "M=M+1\n")))

(define vm-file-name "")

(define (vm-file-name-set! path)
  (set! vm-file-name (get-file-name path)))

;ファイルのパスからファイル名だけを取り出す
(define (get-file-name path)
  (receive (p name k) 
	   (decompose-path path)
	   name))

(define (vm-pop-static i name)
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "@" name "." i "\n"
		 "M=D\n"))


(define (vm-push-static i name)
  (string-append "@" name "." i "\n"
		 "D=M\n"
		 "@SP\n"
		 "A=M\n"
		 "M=D\n"
		 "@SP\n"
		 "M=M+1\n"))
(define vm-neg
  (string-append "@SP\n"
		 "A=M-1\n"
		 "M=-M\n"))
(define vm-not
  (string-append "@SP\n"
		 "A=M-1\n"
		 "M=!M\n"))

(define vm-add
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "A=A-1\n"
		 "M=M+D\n"))
(define vm-sub
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "A=A-1\n"
		 "M=M-D\n"))
(define vm-and
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "A=A-1\n"
		 "M=M&D\n"))
(define vm-or
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "A=A-1\n"
		 "M=M|D\n"))


(define (vm-eq)
  (let1 r (t-f-label)
	(string-append
	 ;戻ってくるアドレスをR13に保存
	 "@" r "\n"
	 "D=A\n"
	 "@R13\n"
	 "M=D\n"
	 
	 ;ここからメイン
	 "@SP\n"
	 "M=M-1\n"
	 "A=M\n"
	 "D=M\n"
	 "A=A-1\n"
	 "D=M-D\n" ;x - y
	 "@TRUE\n"
	 "D;JEQ\n"
	 "@FALSE\n"
	 "0;JMP\n"
	 "(" r ")\n" ;ここに戻る
	 )))
(define (vm-gt)
  (let1 r (t-f-label)
	(string-append
	 ;戻ってくるアドレスをR13に保存
	 "@" r "\n"
	 "D=A\n"
	 "@R13\n"
	 "M=D\n"
	 
	 ;ここからメイン
	 "@SP\n"
	 "M=M-1\n"
	 "A=M\n"
	 "D=M\n"
	 "A=A-1\n"
	 "D=M-D\n" ;x - y
	 "@TRUE\n"
	 "D;JGT\n" ;Dが0より大きければジャンプ
	 "@FALSE\n"
	 "0;JMP\n"
	 "(" r ")\n" ;ここに戻る
	 )))

(define (vm-lt)
  (let1 r (t-f-label)
	(string-append
	 ;戻ってくるアドレスをR13に保存
	 "@" r "\n"
	 "D=A\n"
	 "@R13\n"
	 "M=D\n"
	 
	 ;ここからメイン
	 "@SP\n"
	 "M=M-1\n"
	 "A=M\n"
	 "D=M\n"
	 "A=A-1\n"
	 "D=M-D\n" ;x - y
	 "@TRUE\n"
	 "D;JLT\n" ;Dが0より小さければジャンプ
	 "@FALSE\n"
	 "0;JMP\n"
	 "(" r ")\n" ;ここに戻る
	 )))

;スタックにtrue(-1)を積む 	 
(define vm-true
  (string-append "(TRUE)\n"
                 "@SP\n"
		 "A=M-1\n"
		 "M=-1\n"
		 "@R13\n"
		 "A=M\n"
		 "0;JMP\n"))

;スタックにfalse(0)を積む
(define vm-false
  (string-append "(FALSE)\n"
                 "@SP\n"
		 "A=M-1\n"
		 "M=0\n"
		 "@R13\n"
		 "A=M\n"
		 "0;JMP\n"))