コンピュータシステムの理論と実装11章

コンピュータシステムの理論と実装11章のコンパイラ完成しました。

(use file.util)
(use sxml.serializer)


(define symbol-table 
  (let [(ctable '()) (stable '()) (static-index 0) (field-index 0)
	(argument-index 0) (var-index 0) (class-name '())
	(state '())]
	

    (define (add1-index! sym)
      (cond [(string=? sym "static") 
	     (set! static-index (+ static-index 1))
	     (- static-index 1)]
	    [(string=? sym "field")
	     (set! field-index (+ field-index 1))
	     (- field-index 1)]
	    [(string=? sym "argument")
	     (set! argument-index (+ argument-index 1))
	     (- argument-index 1)]
	    [(string=? sym "var")
	     (set! var-index (+ var-index 1))
	     (- var-index 1)]))

    (lambda (s . lis)
      (cond [(eq? s 'init)
	     (set! static-index 0)
	     (set! field-index 0)
	     (set! argument-index 0)
	     (set! var-index 0)
	     (set! stable (make-hash-table 'string=?))
	     (set! ctable (make-hash-table 'string=?))]
	    [(eq? s 'start-subroutine)
	     (set! argument-index 0)
	     (set! var-index 0)
	     (set! state '())
	     (set! stable (make-hash-table 'string=?))]
	    [(eq? s 'get) 
	     (if (hash-table-get stable (car lis) #f)
	       (hash-table-get stable (car lis))
	       (hash-table-get ctable (car lis) 'none))]
	    [(eq? s 'def)
	     (if (member (caddr lis) '("static" "field"))
	       (hash-table-put! ctable (car lis) (cons (add1-index! (caddr lis)) (cdr lis)))
	       (hash-table-put! stable (car lis) (cons (add1-index! (caddr lis)) (cdr lis))))]
	    [(eq? s 'var-count)
	     (if (member (car lis) '("static" "field"))
	       (length (filter (lambda (val)
				 (string=? (caddr val) (car lis))) (hash-table-values ctable)))
	       (length (filter (lambda (val)
				 (string=? (caddr val) (car lis))) (hash-table-values stable))))

	     ]
	    [(eq? s 'set-class-name)
	     (set! class-name (car lis))]
	    [(eq? s 'get-class-name) class-name]
	    [(eq? s 'set-this)
	     (hash-table-put! stable "this" (list (add1-index! "argument") class-name "argument"))]
	    [(eq? s 'set-state)
	     (set! state (car lis))];メソッドかコンストラクタをコンパイル中にどちらであるかを保存する
	    [(eq? s 'get-state) state]
	    ))))

(define (symbol-table-test)
  (symbol-table 'init)
  (symbol-table 'set-class-name "BankAccount")
  (symbol-table 'def "x" "obj" "static")
  (symbol-table 'def "y" "int" "field")
  (symbol-table 'def "y2" "int" "field")
  (symbol-table 'def "balance" "int" "field")
  (symbol-table 'def "this" "object" "argument")
  (symbol-table 'def "sum" "int" "argument")
  (symbol-table 'def "w" "int" "var"))


(define (read-number1 p lis)
  (let1 c (peek-char p)
	(cond ((eof-object? c)
	       (reverse lis))
	      ((char-numeric? c) 
	       (read-char p)
	       (read-number1  p (cons c lis)))
	      ((char-alphabetic? c)
	       (error "read-number1"))
	      (else
		(reverse lis)))))
	         
(define (read-number p)
  (list 'integerConstant
	(string->number
	  (list->string (read-number1 p '())))))

(define (read-number p)
  (list 'integerConstant
	  (list->string (read-number1 p '()))))

(define (read-string1 p lis)
  (let1 c (peek-char p)
	(cond ((eof-object? c) 
	       (error "read-string1"))
	      ((char=? c #\newline)
	       (error "read-string1 newline"))
	      ((char=? c #\")
	       (read-char p)
	       (reverse lis))
	      (else
		(read-char p)
		(read-string1 p (cons c lis))))))

(define (read-string p)
  (read-char p) ;"を読み飛ばす
  (list 'stringConstant
    (list->string (read-string1 p '()))))


(define (comp-symbol? c)
  (member c (string->list "{}()[].,\;+-*/&|<>=~")))


(define (read-symbol p)
  (let1 c (read-char p)
	;コメントの除去をここでやる
	(cond ((and (char=? c #\/) (char=? (peek-char p) #\/)) ;peek-charでpがeofならエラー
	       (read-char p)
	       (skip-comment p))
	      ((and (char=? c #\/) (char=? (peek-char p) #\*)) ;peek-charでpがeofならエラー
	       (read-char p)
	       (skip-comment*/ p))
	      (else
	       (list 'symbol (x->string c))))));sxmlとして扱うため、文字cをx->stringで文字列に変換

(define (comp-id? c)
  (or (char-alphabetic? c) (char=? c #\_)))

(define (read-id1 p lis)
  (let1 c (peek-char p)
	(cond ((eof-object? c) 
	       (reverse lis))
	      ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_))
	       (read-char p)
	       (read-id1 p (cons c lis)))
	      (else (reverse lis)))))

(define (read-id p)
  (let1 id (list->string (read-id1 p '()))
	(if (member id '("class" "constructor" "function" "method"
			 "field" "static" "var" "int" "char" 
			 "boolean" "void" "true" "false" "null"
			 "this" "let" "do" "if" "else" "while" "return"))
	    (list 'keyword id)
	    (list 'identifier id))))

(define (skip-space p)
  (let1 c (peek-char p)
	(cond ((eof-object? c) '())
	      ((char-whitespace? c)
	       (read-char p)
	       (skip-space p)))))
(define (skip-comment p)
  (let1 c (peek-char p)
	(cond ((eof-object? c) '(comment))
	      ((not (char=? c #\newline))
	       (read-char p)
	       (skip-comment p))
	      (else '(comment))
	      )))

(define (skip-comment*/ p)
  (let1 c (peek-char p)
	(cond ((eof-object? c) '(comment))
	      ((char=? c #\*)
	       (read-char p)
	       (if (char=? (peek-char p) #\/)
		 (begin (read-char p) 
			'(comment))
		 (skip-comment*/ p)))
	      (else
		(read-char p)
		(skip-comment*/ p)))))

(define (lex-advans1 p)
  (let1 c (peek-char p)
	(cond ((eof-object? c) '())
	      ((comp-symbol? c) (read-symbol p))
	      ((char=? c #\") (read-string p))
	      ((char-numeric? c) (read-number p))
	      ((comp-id? c) (read-id p))
	      ((char-whitespace? c) 
	       (skip-space p)
	       (lex-advans p))
	      (else (error "lex-advans1"))
	      )))
(define (lex-advans p)
  (let1 token (lex-advans1 p)
	(if (equal? token '(comment))
	  (lex-advans p)
	  token)))

(define current-token '())
(define next-token '())

(define (next-token-set! p)
  (set! current-token (lex-advans p)))

(define (next-token-set! p)
  (set! current-token next-token)
  (set! next-token (lex-advans p)))

(define (token-init p)
  (set! current-token (lex-advans p))
  (set! next-token (lex-advans p)))

(define (token-keyword? tok)
  (eq? (car tok) 'keyword))

(define (token-symbol? tok)
  (eq? (car tok) 'symbol))

(define (token-integerConstant? tok)
  (eq? (car tok) 'integerConstant))

(define (token-stringConstant? tok)
  (eq? (car tok) 'stringConstant))

(define (token-identifier? tok)
  (eq? (car tok) 'identifier))



(define (token->xml-output tok o)
  (display (string-append "<" (symbol->string (car tok)) ">"
			  (cond ((string=? (cadr tok) "<") "&lt;")
				((string=? (cadr tok) ">") "&gt;")
				((string=? (cadr tok) "&") "&amp;")
				(else (cadr tok)))
			  "</" (symbol->string (car tok)) ">\n") o))

(define (comp-term p o)
  (cond	((token-integerConstant? current-token)
	 ;(display "<term>\n" o) (token->xml-output current-token o) (display "</term>\n" o)
	 (display (string-append "push constant " (cadr current-token) "\n") o)
	 (next-token-set! p))
	((token-stringConstant? current-token)
	 ;(display "<term>\n" o) (token->xml-output current-token o) (display "</term>\n" o)
	 ;(next-token-set! p)
	 (comp-string p o))
	[(string=? (cadr current-token) "(")
	 ;(display "<term>\n" o)
	 ;(token-output p o "(")
	 (next-token-set! p)
	 (comp-expression p o)
	 ;(token-output p o ")")
	 (next-token-set! p)]
	((member (cadr current-token) '("true" "false" "null" "this"))
	 (comp-keyword-constant p o))
	((member (cadr current-token) '("-" "~"))
	 (comp-unary-op p o))
	[(token-identifier? current-token)
	 (cond [(string=? (cadr next-token) "[")
		(comp-array p o)]
	       [(member (cadr next-token) '("." "("))
		(comp-subroutineCall p o)]
	       [else (comp-var p o)])]

	(else 
	  (error "comp-term")) 
	))

(define (comp-var p o)
  ;(symbol-table-test)
  (let1 v (symbol-table 'get (cadr current-token))
	(cond [(string=? (cadr current-token) "this")
	       (display "push pointer 0\n" o)] 
	      [(eq? 'none v) (error "comp-var")]
	      [(string=? (caddr v) "argument")
	       (display (string-append "push argument " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "var")
	       (display (string-append "push local " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "static")
	       (display (string-append "push static " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "field")
	       (display (string-append ;"push argument 0\n"
				       ;"pop pointer 0\n"
				       "push this " (number->string (car v)) "\n") o)]
	      )
	(next-token-set! p)))
(define (comp-var2 p o v key)
	(cond [(string=? key "this")
	       (display "push pointer 0\n" o)]
	      [(eq? 'nove v) (error "comp-var2")]
	      [(string=? (caddr v) "argument")
	       (display (string-append "push argument " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "var")
	       (display (string-append "push local " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "static")
	       (display (string-append "push static " (number->string (car v)) "\n") o)]
	      [(string=? (caddr v) "field")
	       (display (string-append ;"push argument 0\n"
				       ;"pop pointer 0\n"
				       "push this " (number->string (car v)) "\n") o)]
	      ))
(define (comp-var3 v key)
	(cond [(string=? key "this")
	       "push pointer 0\n"] 
	      [(eq? 'none v) (error "comp-var3")]
	      [(string=? (caddr v) "argument")
	       (string-append "push argument " (number->string (car v)) "\n")]
	      [(string=? (caddr v) "var")
	       (string-append "push local " (number->string (car v)) "\n") ]
	      [(string=? (caddr v) "static")
	       (string-append "push static " (number->string (car v)) "\n")]
	      [(string=? (caddr v) "field")
	       (string-append ;"push argument 0\n"
				       ;"pop pointer 0\n"
				       "push this " (number->string (car v)) "\n")]
	      ))
(define (comp-pop-var v)
	(cond [(eq? 'none v) (error "comp-pop-var")]
	      [(string=? (caddr v) "argument")
	       (string-append "pop argument " (number->string (car v)) "\n")]
	      [(string=? (caddr v) "var")
	       (string-append "pop local " (number->string (car v)) "\n") ]
	      [(string=? (caddr v) "static")
	       (string-append "pop static " (number->string (car v)) "\n")]
	      [(string=? (caddr v) "field")
	       (string-append ;"push argument 0\n"
				       ;"pop pointer 0\n"
				       "pop this " (number->string (car v)) "\n")]
	      ))
(define (comp-array p o)
  (comp-var p o)
  (next-token-set! p)
  (comp-expression p o)
  (display (string-append "add\n"
			  "pop pointer 1\n"
			  "push that 0\n") o)
  
  (next-token-set! p))

(define (comp-pop-array p o)
  (comp-var p o)
  (next-token-set! p)
  (comp-expression p o)
  (display (string-append "add\n"
			  "pop pointer 1\n"
			  "push that 0\n") o)
  
  (next-token-set! p))
(define (comp-string p o)
  (let1 len (string-length (cadr current-token))
	(display (string-append "push constant " (number->string len) "\n") o)
	(display "call String.new 1\n" o)
	(for-each (lambda (ch)
		    (display (string-append "push constant " 
					    (number->string (char->integer ch)) "\n") o)
		    (display "call String.appendChar 2\n" o))
		  (string->list (cadr current-token)))
	(next-token-set! p)))

(define (comp-keyword-constant p o)
  (cond [(or (string=? (cadr current-token) "false") (string=? (cadr current-token) "null"))
	 (display "push constant 0\n" o)]
	[(string=? (cadr current-token) "true")
	 (display (string-append "push constant 1\n"
				 "neg\n")
		  o)]
	[(string=? (cadr current-token) "this") (display "push pointer 0\n" o) ])
  (next-token-set! p))

(define (comp-unary-op p o)
  (cond [(string=? (cadr current-token) "-")
	 (next-token-set! p)
	 (comp-term p o)
	 (display "neg\n" o)]
	[(string=? (cadr current-token) "~")
	 (next-token-set! p)
	 (comp-term p o)
	 (display "not\n" o)]))


(define (comp-expression p o)
  ;(display "<expression>\n" o)
  (comp-term p o)
  (comp-expression1 p o)
  ;(display "</expression>\n" o))
  )


;(define (comp-expression1 p o)
;  (if (member (cadr current-token) '("+" "-" "*" "/" "&" "|"
;				     "<" ">" "="))
 ;   (begin (token-word?-output p o 'symbol)
;	   (comp-term p o)
;	   (comp-expression1 p o))))

(define (comp-expression1 p o)
  (if (member (cadr current-token) '("+" "-" "*" "/" "&" "|"
				     "<" ">" "="))
    (let1 op (cadr current-token)
	  ;(token-word?-output p o 'symbol)
	  (next-token-set! p)
	   (comp-term p o)
	   (comp-op op p o)
	   (comp-expression1 p o))))

(define (comp-op op p o)
  (cond [(string=? op "+")
	 (display "add\n" o)]
	[(string=? op "-")
	 (display "sub\n" o)]
	[(string=? op "&")
	 (display "and\n" o)]
	[(string=? op "|")
	 (display "or\n" o)]
	[(string=? op "<")
	 (display "lt\n" o)]
	[(string=? op ">")
	 (display "gt\n" o)]
	[(string=? op "=")
	 (display "eq\n" o)]
	[(string=? op "*")
	 (display "call Math.multiply 2\n" o)]
	[(string=? op "/")
	 (display "call Math.divide 2\n" o)]
	))

(define (comp-expressionList p o)
  (if (not (string=? (cadr current-token) ")"))
    (begin (comp-expression p o)
	  (+ 1 (comp-expressionList1 p o)))
    0))



(define (comp-expressionList1 p o)
  (cond [(string=? (cadr current-token) ",")
	 (next-token-set! p)
	 (comp-expression p o)
	 (+ 1 (comp-expressionList1 p o))]
	[else 0]))

(define (comp-returnStatement p o)
  ;(display "<returnStatement>\n" o)
  ;(token->xml-output current-token o)
  (next-token-set! p)
  (if (not (string=? (cadr current-token)  ";"))
    (comp-expression p o))
  (if (not (string=? (cadr current-token) ";"))
    (error "comp-returnStatement"))
  (next-token-set! p)
  (display "return\n" o))

(define (comp-subroutineCall p o)
  (cond ((token-identifier? current-token)
	 ;(token->xml-output current-token o)
	 ;(next-token-set! p)
	 (cond [(string=? (cadr next-token) "(")
		;(token->xml-output current-token o)
		;(next-token-set! p)
		;(comp-expressionList p o)]
		(comp-in-m-call p o)]
	       [(string=? (cadr next-token) ".")
	       	;(token->xml-output current-token o) ;"<symbol> . </symbol>"を出力
		;(next-token-set! p)
		;(token->xml-output current-token o) ;"<identifire> メソッド名 </identifire>"を出力
		;(next-token-set! p)
		;(token->xml-output current-token o) ;"<symbol> ( </symbol>"を出力
		;(next-token-set! p)
		;(comp-expressionList p o)]
		(comp-call p o)]
	       [else (error (string-append"subroutineCall " (cadr current-token)))])
	 (if (string=? (cadr current-token) ")")
	   (next-token-set! p)
           (error "subroutineCall"))
	 )
	 ;(next-token-set! p))
	(else
	  (error "subroutineCall"))))

(define (comp-in-m-call p o);同じクラス内のメソッド呼出しをコンパイルする。
  (let1 method-name (cadr current-token)
	(next-token-set! p)
	(next-token-set! p)
	(display "push pointer 0\n" o)
	(display (string-append "call " 
				(symbol-table 'get-class-name)
				"." method-name " "
				(number->string (+ 1 (comp-expressionList p o))) "\n") o);メソッドにthisオブジェクトを渡すから+1

	))
(define (comp-call p o)
  (let1 name1 (cadr current-token)
	(next-token-set! p)
	(next-token-set! p)
	(let [(name2 (cadr current-token)) (obj (symbol-table 'get name1))]
	  (next-token-set! p)
	  (next-token-set! p)
	  (cond [(eq? obj 'none) ;functionとコンストラクタの呼び出しをコンパイル
		 (display (string-append "call " name1 "." name2 " " 
					 (number->string (comp-expressionList p o)) "\n") o)]
		[else 
		  (comp-var2 p o obj name1);メソッドにオブジェクトを渡す 
		  (display (string-append "call " (cadr obj) "." name2 " "
					  (number->string (+ 1 (comp-expressionList p o))) "\n") o)]

		))))
	      
(define (comp-doStatement p o)
  ;(display "<doStatement>\n" o)
  ;(token->xml-output current-token o)
  (next-token-set! p)
  (comp-subroutineCall p o)
  ;(token->xml-output current-token o)
  (if (not (string=? (cadr current-token) ";"))
    (error "comp-doStatement not \";\""))

  (display "pop temp 0\n" o)

  ;(display "</doStatement>\n" o)
  (next-token-set! p))

(define (token-output p o str)
  (if (string=? (cadr current-token) str)
    (begin ;(token->xml-output current-token o)
	   (next-token-set! p))
    (error (string-append "not " str))))


(define (token-word?-output p o sym)
  (if (eq? (car current-token) sym)
    (begin ;(token->xml-output current-token o)
	   (next-token-set! p))
    (error current-token))) 

(define (make-label-fn str)
  (let1 count -1
	(lambda ()
	  (set! count (+ count 1))
	  (string-append str (number->string count)))))

(define make-while_loop-label (make-label-fn "WHILE_LOOP:"))
(define make-while_true-label (make-label-fn "WHILE_TRUE:"))
(define make-while_end-label (make-label-fn "WHILE_END:"))

(define (comp-whileStatement p o)
  (let ([loop-label (make-while_loop-label)]
	[true-label (make-while_true-label)]
	[end-label (make-while_end-label)])
        ;(display "<whileStatement>\n" o)
        ;(token-output p o "while")
        (next-token-set! p)
        ;(token-output p o "(")
        (next-token-set! p)
	(display (string-append "label " loop-label "\n") o)
        (comp-expression p o)
	(display (string-append "if-goto " true-label "\n"
				"goto " end-label "\n"
				"label " true-label "\n") o)
        ;(token-output p o ")")
        (next-token-set! p)
        ;(token-output p o "{")
	(next-token-set! p)
        (comp-statements p o)
        ;(token-output p o "}")
	(next-token-set! p)
	(display (string-append "goto " loop-label "\n"
				"label " end-label "\n") o)))

  
(define (comp-letStatement p o)
  ;(display "<letStatement>\n" o)
  ;(token-output p o "let")
  (next-token-set! p)
  ;(token-word?-output p o 'identifier)
  (if (not (token-identifier? current-token))
    (error "comp-letStatement not identifier"))
  (if (string=? (cadr next-token) "[")
    (let1 push-var-code (comp-var3 (symbol-table 'get (cadr current-token)) (cadr current-token))
	  (next-token-set! p)
	  (next-token-set! p) ;[を飛ばす
	  (comp-expression p o)
	  (display push-var-code o)
	  (display "add\n" o)
	  (next-token-set! p) ;]を飛ばす
	  (next-token-set! p) ;=を飛ばす
	  (comp-expression p o)
	  (display (string-append "pop temp 0\n"
				  "pop pointer 1\n"
				  "push temp 0\n"
				  "pop that 0\n") o))
    (let1 pop-code (comp-pop-var (symbol-table 'get (cadr current-token)))
	  (next-token-set! p)
	  (next-token-set! p) ; =を飛ばす
	  (comp-expression p o)
	  (display pop-code o))
    )
  (next-token-set! p)) ;  ";"を飛ばす
  


(define make-if_true-label (make-label-fn "IF_TRUE:"))
(define make-if_false-label (make-label-fn "IF_FALSE:"))
(define make-if_end-label (make-label-fn "IF_END:"))

(define (comp-ifStatement p o)
  (let ([if-true-lab (make-if_true-label)] [if-false-lab (make-if_false-label)])
    ;(display "<ifStatement>\n" o)
    ;(token-output p o "if")
    (next-token-set! p)
    ;(token-output p o "(")
    (next-token-set! p)
    (comp-expression p o)
    ;(token-output p o ")")
    (next-token-set! p)
    (display (string-append "if-goto " if-true-lab "\n") o)
    (display (string-append "goto " if-false-lab "\n") o)
    (display (string-append "label " if-true-lab "\n") o)

    ;(token-output p o "{")
    (next-token-set! p)
    (comp-statements p o)
    ;(token-output p o "}")
    (next-token-set! p)
  (if (string=? (cadr current-token) "else")
    (let1 if-end-lab (make-if_end-label) 
      (display (string-append "goto " if-end-lab "\n"
			      "label " if-false-lab "\n") o)
      ;(token-output p o "else")
      (next-token-set! p)
      ;(token-output p o "{")
      (next-token-set! p)
      (comp-statements p o)
      ;(token-output p o "}")
      (next-token-set! p)
      (display (string-append "label " if-end-lab "\n") o))
    (display (string-append "label " if-false-lab "\n") o)))) ;elseがないとき


(define (comp-statements1 p o)
  (cond ((string=? (cadr current-token) "return")
	 (comp-returnStatement p o)
	 (comp-statements1 p o))
	((string=? (cadr current-token) "do")
	 (comp-doStatement p o)
	 (comp-statements1 p o))
	((string=? (cadr current-token) "let")
	 (comp-letStatement p o)
	 (comp-statements1 p o))
	((string=? (cadr current-token) "if")
	 (comp-ifStatement p o)
	 (comp-statements1 p o))
	((string=? (cadr current-token) "while")
	 (comp-whileStatement p o)
	 (comp-statements1 p o))


	)

  )

(define (comp-statements p o)
  ;(display "<statements>\n" o)
  (comp-statements1 p o)
  ;(display "</statements>\n" o)
  )

(define (comp-type? token)
  (or (member (cadr token) '("int" "char" "boolean"))
      (token-identifier? token)))

(define (comp-varDec1 p o)
  (if (string=? (cadr current-token) ",")
    (begin (token-output p o ",")
	   (token-word?-output p o 'identifier)
	   (comp-varDec1 p o))))

(define (comp-varDec1 p o type kind)
  (if (string=? (cadr current-token) ",")
    (begin (token-output p o ",")
	   (symbol-table 'def (cadr current-token) type kind)
	   (token-word?-output p o 'identifier)
	   (comp-varDec1 p o type kind))))

(define (comp-varDec p o)
  (let ((name '()) (type '()))
	  ;(display "<varDec>\n" o)
	  ;(token-output p o "var")
	  (next-token-set! p)
	  (if (not (comp-type? current-token))
	    (error "comp-varDec"))
	  (set! type (cadr current-token))
	  (next-token-set! p)

	  (set! name (cadr current-token)) 
	  ;(token-word?-output p o 'identifier)
	  (next-token-set! p)
	  (symbol-table 'def name type "var")
	  (comp-varDec1 p o type "var")
	  ;(token-output p o ";")
	  (next-token-set! p)))

(define (comp-varDec* p o)
  (if (string=? (cadr current-token) "var")
    (begin (comp-varDec p o)
	   (comp-varDec* p o))))

(define (comp-classVarDec p o)
   (let ((kind '()) (type '()) (name '()))
	  ;(display "<classVarDec>\n" o)
	  (if (not (member (cadr current-token) '("static" "field")))
	    (error "comp-classVarDec"))
	  (set! kind (cadr current-token))
	  (next-token-set! p)

	  (if (not (comp-type? current-token))
	   (error "comp-varDec"))
	  (set! type (cadr current-token))
	  (next-token-set! p)
	  (set! name (cadr current-token))
	  (token-word?-output p o 'identifier)

	  (symbol-table 'def name type kind)
	  (comp-varDec1 p o type kind)
	  (token-output p o ";")))

(define (comp-classVarDec* p o)
  (if (member (cadr current-token) '("static" "field"))
    (begin (comp-classVarDec p o)
	   (comp-classVarDec* p o))))


(define (comp-subroutineBody p o f-name)
  ;(display "<subroutineBody>\n" o)
  ;(token-output p o "{")
  (next-token-set! p)
  (comp-varDec* p o)
  (display (string-append "function "
			  (symbol-table 'get-class-name)
			  "."
			  f-name " " (number->string (symbol-table 'var-count "var")) "\n") o)
  (cond [(eq? (symbol-table 'get-state) 'constructor)
	 (display (string-append "push constant " (number->string (symbol-table 'var-count "field")) "\n"
				 "call Memory.alloc 1\n"
				 "pop pointer 0\n") o)]
	[(eq? (symbol-table 'get-state) 'method)
	 (display (string-append "push argument 0\n"
				 "pop pointer 0\n") o)])
  (comp-statements p o)
  ;(token-output p o "}")
  (next-token-set! p)
  ;(display "</subroutineBody>\n" o))
  )

;(define (comp-parameterList p o)
;  (display "<parameterList>\n" o)
 ; (cond ((string=? (cadr current-token) ")") '())
;	((comp-type? current-token)
;	 (token->xml-output current-token o)
;	 (next-token-set! p)
;	 (token-word?-output p o 'identifier)
;	 (comp-parameterList1 p o)) 
;	(else
;	  (error "comp-parameterList")))
 ; (display "</parameterList>\n" o))

(define (comp-parameterList p o)
  ;(display "<parameterList>\n" o)
  (cond [(string=? (cadr current-token) ")") '()]
	[(comp-type? current-token)
	 (comp-parameterList-set-symbol-table p o)
	 (comp-parameterList1 p o)] 
	[else
	  (error "comp-parameterList")]))
  ;(display "</parameterList>\n" o))

(define (comp-parameterList-set-symbol-table p o)
  (let ((type '()) (name '()))
    (cond [(comp-type? current-token)
	   (set! type (cadr current-token))
	   (next-token-set! p)
	   (if (token-identifier? current-token)
	     (set! name (cadr current-token))
	     (error "comp-parameterList-set-symbol-table"))]
	  [else
	    (error "comp-parameterList-set-symbol-table")])
    (next-token-set! p)
    (symbol-table 'def name type "argument")))

;(define (comp-parameterList1 p o)
 ; (if (string=? (cadr current-token) ",")
  ;  (begin (token-output p o ",")
;	   (if (comp-type? current-token)
;	     (token->xml-output current-token o)
;	     (error "comp-parameterList1 type"))
;	   (next-token-set! p)
;	   (token-word?-output p o 'identifier)
;	   (comp-parameterList1 p o))))

(define (comp-parameterList1 p o)
  (if (string=? (cadr current-token) ",")
    (begin (token-output p o ",")
	   (comp-parameterList-set-symbol-table p o)
	   (comp-parameterList1 p o))))

(define (comp-subroutineDec p o)
  (cond ((member (cadr current-token) '("constructor" "function" "method"))
	 (symbol-table 'start-subroutine)
	 (cond [(string=? (cadr current-token) "method")
	        (symbol-table 'set-this)
		(symbol-table 'set-state 'method)]
	       [(string=? (cadr current-token) "constructor")
		(symbol-table 'set-state 'constructor)])
	      
	 ;(display "<subroutineDec>\n" o)
	 ;(token->xml-output current-token o)
	 (next-token-set! p)
	 (if (or (string=? (cadr current-token) "void")
		 (comp-type? current-token))
	   (begin ;(token->xml-output current-token o)
		  (next-token-set! p)
		  ;(token-word?-output p o 'identifier)
		  (let1 fn-name (cadr current-token)
		    (next-token-set! p)
		    ;(token-output p o "(")
		    (next-token-set! p)
		    (comp-parameterList p o)
		    ;(token-output p o ")")
		    (next-token-set! p)
		    (comp-subroutineBody p o fn-name)
		    ))
	   (error "comp-subroutineDec not type, not void")))
	(else 
	  (error "comp-subroutineDec not constructor, not function, not method"))))

(define (comp-subroutineDec* p o)
  (if (member (cadr current-token) '("constructor" "function" "method"))
    (begin (comp-subroutineDec p o)
	   (comp-subroutineDec* p o))))

  
(define (comp-class p o)
  ;(display "<class>\n" o)
  (token-output p o "class")

  (symbol-table 'set-class-name (cadr current-token))

  (token-word?-output p o 'identifier)
  (token-output p o "{")
  (comp-classVarDec* p o)
  (comp-subroutineDec* p o)
  (token-output p o "}"))

(define (comp-test str f)
  (call-with-input-string str
    (lambda (p)
      (symbol-table 'init)
      (symbol-table-test)
      (token-init p)
      (f p (current-output-port)))))


(define (lex-test21 p lis)
  (let1 c (peek-char p)
	(if (eof-object? c)
	  (srl:sxml->xml (cons 'tokens (remove null? (reverse lis))))
	  (lex-test21 p (cons (lex-advans p) lis)))))
(define (lex-test2 p)
  (lex-test21 p '()))

;アウトプット用のパスを得る
;例:"text/xxx.jack" から "test/xxx.vm" 
(define (jack->xml-path-name1 path)
  (receive (p name k)
	   (decompose-path path)
	   (string-append p "/" name ".vm")))


(define (jack-analyzer1 path)
  (call-with-input-file path
    (lambda (p)
      (token-init p)
      (call-with-output-file (jack->xml-path-name1 path)
	(lambda (o)
	  (symbol-table 'init)
	  (comp-class p o))))))

(define (jack-analyzer path)
  (if (and (path-extension path) (string=? (path-extension path) "jack"))
    (jack-analyzer1 path)
    (let1 file-list (remove (lambda (s) (not (and (path-extension s)
						  (string=? (path-extension s) "jack")))) 
			    (sys-readdir path)) ;ディレクトリの中にある.jackファイルの名前の文字列だけを取り出す
	  (for-each (lambda (s)
		      (jack-analyzer1 (string-append path "/" s))) 
		    file-list))))

(define (lex-test3 path)
  (call-with-input-file path
   (lambda (p)
     (let1 xml-txt (lex-test2 p)
	(call-with-output-file (jack->xml-path-name1 path)
	 (lambda (p2)
	   (display xml-txt p2)))))))

(define test-str "if (x < 153)
		   {let city=\"Paris\";}")

(define lex-test call-with-input-string)