言語処理系とは: 補題

うーん、昨日やってた簡単なインタプリタ/コンパイラ作成ですが、気になってた再帰部分を末尾再帰に書き換えられるのか、ってやってみたんですが、上手く行かなかったですね。
継続受け渡しで書き換えると形式的には末尾再帰になるんですが、最適化はされなさそうです。
あと、コンパイラのコードもちょっとムダな部分があったんで、より関数プログラミングっぽく書きなおしてみました。

	#lang racket
	(require srfi/1)
	;;; 字句解析を行う関数 getToken
	(define (getToken)
	(let again ((n 0) (c (read-char)))
	(case c
	((#\+) (values n 'PLUS_OP))
	((#\-) (values n 'MINUS_OP))
	((#\newline #\return) (values n 'EOL))
	((#\space) (again n (read-char)))
	(else
	(if (char-numeric? c)
	(letrec ((proc
	(lambda (n c)
	(+ (* n 10)
	(apply - (map char->integer `(,c #\0)))))))
	(let loop ((n (proc n c)) (c (peek-char)))
	(if (char-numeric? c)
	(let ((c (read-char)))
	(loop (proc n c) (peek-char)))
	(values n 'NUM))))
	(error "bad char '~a'" c))))))
	;;; 構文木を作るプログラム
	(define (readExpr tokenVal currentToken)
	(let ast ((e (readNum tokenVal currentToken)))
	(let-values (((tokenVal currentToken) (getToken)))
	(if (or (eq? currentToken 'PLUS_OP) (eq? currentToken 'MINUS_OP))
	(ast
	(alist-cons 'right (let-values (((v t) (getToken)))
	(readNum v t))
	(alist-cons 'left e
	(alist-cons 'op currentToken '()))))
	e))))
	(define (readNum tokenVal currentToken)
	(let ((e '()))
	(if (eq? currentToken 'NUM)
	(alist-cons 'val tokenVal (alist-cons 'op 'NUM e))
	(error "bad expression: NUM expected\n"))))
	;;; 解釈実行: インタプリタ
	;(define (evalExpr e)
	; (case (cdr (assq 'op e))
	; ((NUM) (cdr (assq 'val e)))
	; ((PLUS_OP) (+ (evalExpr (cdr (assq 'left e)))
	; (evalExpr (cdr (assq 'right e)))))
	; ((MINUS_OP) (- (evalExpr (cdr (assq 'left e)))
	; (evalExpr (cdr (assq 'right e)))))
	; (else (error "evalExpr: bad expression\n"))))
	;; 普通の末尾再帰にはならない
	(define (evalExpr e cont)
	(case (cdr (assq 'op e))
	((NUM) (cont (cdr (assq 'val e))))
	((PLUS_OP) (evalExpr (cdr (assq 'right e))
	(lambda (v)
	(evalExpr (cdr (assq 'left e))
	(lambda (u)
	(cont (+ u v)))))))
	((MINUS_OP) (evalExpr (cdr (assq 'right e))
	(lambda (v)
	(evalExpr (cdr (assq 'left e))
	(lambda (u)
	(cont (- u v)))))))
	(else (error "evalExpr: bad expression\n"))))
	;;; main プログラム
	;(define (main)
	; (let-values (((tokenVal currentToken) (getToken)))
	; (let ((e (readExpr tokenVal currentToken)))
	; (display (evalExpr e)))))
	(define (main)
	(let-values (((tokenVal currentToken) (getToken)))
	(let ((e (readExpr tokenVal currentToken)))
	(evalExpr e display))))

view raw interpreter.rkt hosted with ❤ by GitHub

	#lang racket
	(require srfi/1)
	;;; 字句解析を行う関数 getToken
	(define (getToken)
	(let again ((n 0) (c (read-char)))
	(case c
	((#\+) (values n 'PLUS_OP))
	((#\-) (values n 'MINUS_OP))
	((#\newline #\return) (values n 'EOL))
	((#\space) (again n (read-char)))
	(else
	(if (char-numeric? c)
	(letrec ((proc
	(lambda (n c)
	(+ (* n 10)
	(apply - (map char->integer `(,c #\0)))))))
	(let loop ((n (proc n c)) (c (peek-char)))
	(if (char-numeric? c)
	(let ((c (read-char)))
	(loop (proc n c) (peek-char)))
	(values n 'NUM))))
	(error "bad char '~a'" c))))))
	;;; 構文木を作るプログラム
	(define (readExpr tokenVal currentToken)
	(let ast ((e (readNum tokenVal currentToken)))
	(let-values (((tokenVal currentToken) (getToken)))
	(if (or (eq? currentToken 'PLUS_OP) (eq? currentToken 'MINUS_OP))
	(ast
	(alist-cons 'right (let-values (((v t) (getToken)))
	(readNum v t))
	(alist-cons 'left e
	(alist-cons 'op currentToken '()))))
	e))))
	(define (readNum tokenVal currentToken)
	(let ((e '()))
	(if (eq? currentToken 'NUM)
	(alist-cons 'val tokenVal (alist-cons 'op 'NUM e))
	(error "bad expression: NUM expected\n"))))
	;;; コンパイラ
	(define (compileExpr e)
	(list->vector (reverse (Codes e '() values))))
	;(define (Codes e nCode)
	; (case (cdr (assq 'op e))
	; ((NUM) (cons `((opcode . PUSH)
	; (operand ,@(cdr (assq 'val e)))) nCode))
	; ((PLUS_OP) (cons '((opcode . ADD))
	; (Codes (cdr (assq 'right e))
	; (Codes (cdr (assq 'left e)) nCode))))
	; ((MINUS_OP) (cons '((opcode . SUB))
	; (Codes (cdr (assq 'right e))
	; (Codes (cdr (assq 'left e)) nCode))))))
	;; 普通の末尾再帰にはならない
	(define (Codes e nCode cont)
	(case (cdr (assq 'op e))
	((NUM) (cont (cons `((opcode . PUSH)
	(operand ,@(cdr (assq 'val e)))) nCode)))
	((PLUS_OP) (Codes (cdr (assq 'left e)) nCode
	(lambda (v)
	(Codes (cdr (assq 'right e)) v
	(lambda (u)
	(cont (cons '((opcode . ADD)) u)))))))
	((MINUS_OP) (Codes (cdr (assq 'left e)) nCode
	(lambda (v)
	(Codes (cdr (assq 'right e)) v
	(lambda (u)
	(cont (cons '((opcode . SUB)) u)))))))))
	;;; コード生成。
	;;; スタックマシンのコードを Scheme になおして出力する。
	;(define (codeGen Codes)
	; ; この辺で、今回のスタックマシンに必要な基本関数を文字列として定義する。
	; (let ((template "(define (push n stack)\n (cons n stack))\n
	;(define (pop stack)\n (values (car stack) (cdr stack)))\n
	;(define-syntax define-alu\n (syntax-rules ()\n ((_ name sym)\n (define (name stack)\n (let-values (((b stack) (pop stack)))\n (let-values (((a stack) (pop stack)))\n (push (sym a b) stack)))))))\n
	;(define-alu add +)\n
	;(define-alu sub -)\n
	;(define (print stack)\n (let-values (((a stack) (pop stack)))\n (display a)\n (newline)\n stack))\n\n")
	; (nCode (vector-length Codes))) ; 入力されたコードの長さ
	; ;; ここの手続き(proc)はインデントの為で実は必須ではない。
	; (letrec ((proc
	; (lambda (x . y)
	; (let ((z (* 2 x)))
	; (make-string (if (null? y)
	; z
	; (+ z (car y))) #\space)))))
	; ;; 関数本体。
	; ;; Scheme のコードを文字列として組み立てる。
	; (let loop ((i 0) (n nCode) (str (string-append (proc nCode 5) "'()")))
	; (if (= i nCode)
	; (display (string-append template
	; "(define (main)\n"
	; str
	; ")\n"))
	; (case (cdr (assq 'opcode (vector-ref Codes i)))
	; ((PUSH) (loop (+ i 1) (- n 1)
	; (string-append (proc n)
	; "(push "
	; (number->string
	; (cdr
	; (assq 'operand
	; (vector-ref Codes i))))
	; " \n" str ")")))
	; ((ADD) (loop (+ i 1) (- n 1)
	; (string-append (proc n)
	; "(add \n"
	; str
	; ")")))
	; ((SUB) (loop (+ i 1) (- n 1)
	; (string-append (proc n)
	; "(sub \n"
	; str
	; ")")))
	; ((PRINT) (loop (+ i 1) (- n 1)
	; (string-append (proc n)
	; "(print \n"
	; str
	; ")")))))))))
	(define (codeGen Codes)
	; この辺で、今回のスタックマシンに必要な基本関数を文字列として定義する。
	(let ((template "(define (push n stack)\n (cons n stack))\n
	(define (pop stack)\n (values (car stack) (cdr stack)))\n
	(define-syntax define-alu\n (syntax-rules ()\n ((_ name sym)\n (define (name stack)\n (let-values (((b stack) (pop stack)))\n (let-values (((a stack) (pop stack)))\n (push (sym a b) stack)))))))\n
	(define-alu add +)\n
	(define-alu sub -)\n
	(define (print stack)\n (let-values (((a stack) (pop stack)))\n (display a)\n (newline)\n stack))\n\n")
	(nCode (vector-length Codes))) ; 入力されたコードの長さ
	;; ここの手続き(proc)はインデントの為で実は必須ではない。
	(letrec ((proc
	(lambda (x . y)
	(let ((z (* 2 x)))
	(make-string (if (null? y)
	z
	(+ z (car y))) #\space)))))
	;; 関数本体。
	;; Scheme のコードを文字列として組み立てる。
	(let loop ((i 0) (n nCode) (str (string-append (proc nCode 5) "'()")))
	(if (= i nCode)
	(display (string-append template
	"(define (main)\n"
	str
	")\n"))
	(loop (+ i 1) (- n 1)
	(string-append (proc n)
	(case (cdr (assq 'opcode (vector-ref Codes i)))
	((PUSH) (string-append "(push "
	(number->string
	(cdr
	(assq 'operand
	(vector-ref Codes i))))
	"\n"))
	((ADD) "(add \n")
	((SUB) "(sub \n")
	((PRINT) "(print \n"))
	str
	")")))))))
	;;; main プロシージャ
	(define (main)
	(let-values (((v t) (getToken)))
	(let ((e (readExpr v t)))
	(let ((Codes (vector-append (compileExpr e) #(((opcode . PRINT))))))
	(codeGen Codes)))))

view raw compiler.rkt hosted with ❤ by GitHub

さて、lexと格闘、です。