８章のVM変換器完成

コンピュータシステムの理論と実装８章のVM変換器完成しました。
７章で作ったものに、関数の定義をできるようにしたり、goto文などを追加しています。

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

	      ((vm-label? command) 
	       (vm-label (cadr command)))
	      ((vm-goto? command)
	       (vm-goto (cadr command)))
	      ((vm-if-goto? command)
	       (vm-if-goto (cadr command)))

	      ((vm-function? command)
	       (vm-function (cadr command) (caddr command)))

	      ((vm-return? command)
	       vm-return)

	      ((vm-call? command)
	       (vm-call (cadr command) (caddr command)))

	      (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
					     "@256\n"
					     "D=A\n"
					     "@SP\n"
					     "M=D\n"
					     (vm-call "Sys.init" "0")
					     vm-true
					     vm-false
					     (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
						    "@256\n"
						    "D=A\n"
						    "@SP\n"
						    "M=D\n"
						    (vm-call "Sys.init" "0")
						    vm-true
						    vm-false
						    )
						  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 (vm-label? command)
  (string=? (car command) "label"))
    
(define (vm-label labe)
  (string-append "(" function-name "$" labe ")\n"))

(define (vm-goto? command)
  (string=? (car command) "goto"))

(define (vm-goto labe)
  (string-append "@" function-name "$" labe "\n"
		 "0;JMP\n"))

(define (vm-if-goto? command)
  (string=? (car command) "if-goto"))

(define (vm-if-goto labe)
  (string-append "@SP\n"
		 "M=M-1\n"
		 "A=M\n"
		 "D=M\n"
		 "@" function-name "$" labe "\n"
		 "D;JNE\n"))

(define (vm-call? command)
  (string=? (car command) "call"))

(define return-address-n 0)

(define (return-count!)
  (set! return-address-n (+ return-address-n 1)))

(define (make-return-address)
  (let1 return-address (string-append "return$" (number->string return-address-n))
	(return-count!)
	return-address))

(define (vm-call f n)
  (let ((push (lambda (s)
	       (string-append "@" s "\n"
			      "D=M\n"
			      "@SP\n"
			      "M=M+1\n"
			      "A=M-1\n"
			      "M=D\n")))
	(return-address (make-return-address)))
    (string-append
      "@" return-address "\n"
      "D=A\n"
      "@SP\n"
      "M=M+1\n"
      "A=M-1\n"
      "M=D\n"
      (apply string-append (map push (list "LCL" "ARG" "THIS" "THAT")))
      "@SP\n"
      "D=M\n"
      "@" n "\n"
      "D=D-A\n"
      "@5\n"
      "D=D-A\n"
      "@ARG\n"
      "M=D\n"
      "@SP\n"
      "D=M\n"
      "@LCL\n"
      "M=D\n"
      "@" f "\n"
      "0;JMP\n"
      "(" return-address ")\n")))

(define (vm-return? command)
  (string=? (car command) "return"))
(define vm-return
  (string-append
    "@LCL\n"
    "D=M\n"
    "@R13\n"
    "M=D\n"

    ;RET = *(FRAME-5)
    "@5\n"
    "D=A\n"
    "@R13\n"
    "A=M-D\n"
    "D=M\n"
    "@R14\n"
    "M=D\n"


    "@SP\n"
    "A=M-1\n"
    "D=M\n"
    "@ARG\n"
    "A=M\n"
    "M=D\n"

    "D=A+1\n"
    "@SP\n"
    "M=D\n"

    "@R13\n"
    "A=M-1\n"
    "D=M\n"
    "@THAT\n"
    "M=D\n"

    "@2\n"
    "D=A\n"
    "@R13\n"
    "A=M-D\n"
    "D=M\n"
    "@THIS\n"
    "M=D\n"

    "@3\n"
    "D=A\n"
    "@R13\n"
    "A=M-D\n"
    "D=M\n"
    "@ARG\n"
    "M=D\n"

    "@4\n"
    "D=A\n"
    "@R13\n"
    "A=M-D\n"
    "D=M\n"
    "@LCL\n"
    "M=D\n"

    ;goto RET
    "@R14\n"
    "A=M\n"
    "0;JMP\n"))

(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 (vm-function? command)
  (string=? (car command) "function"))

(define function-name "")

(define (vm-function fname k)
  (set! function-name fname)
  (string-append "(" fname ")\n"
		 (apply string-append 
			(map push_constant (make-list (string->number k) 0)))))

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