llvm : tutorial : lexer,parser

llvmに関する基本的な(?)ドキュメントには一通り目を通した感じなので、次は『LLVM Tutorial』に沿って、Kaleidoscopeという言語を実装してみることにする。
上記チュートリアルでは実装言語として、C++及びOCamlが用いられていたが、自分はcommon lispが一番慣れているので、それを使うことにする。

lexer

まずlexer。
詳細に関してはオリジナルの文書で詳しく説明されているので、ここでは実装を載せるだけにする。
　※ 実装に際して、直接参考にさせてもらったのはC++版。ただし、直訳というよりは意訳なので、細かいところでオリジナルのものと挙動が違っている可能性がある。
参照: a.equal-case

;;; トークンの型
;;; 実際にプログラム内で利用することはないが、トークンの構成要素を明示しておいた方が分かりやすいので、ここに記述
(deftype token-type () '(or (member :def :extern :identifier :number)
                            character))

;;; 文字種判定関数群
(defun isspace (char) (case char ((#\Space #\Return #\Newline #\Tab) t)))  ; 空白文字
(defun isalpha (char) (or (char<= #\A char #\Z) (char<= #\a char #\z)))    ; 英字:   [a-z] or [A-Z]
(defun isdigit (char) (char<= #\0 char #\9))                               ; 数字:   [0-9]
(defun isalnum (char) (or (isalpha char) (isdigit char)))                  ; 英数字: [a-z] or [A-Z] or [0-9]
(defun isdouble(char) (or (isdigit char) (char= #\. char)))                ; 小数:   [0-9] or .

;;; トークンが識別子 or 数値の場合に、その値を保存/取得するための関数群
(defun set-identifier (value) (setf (get :identifier :value) value))      
(defun set-number     (value) (setf (get :number     :value) value))  
(defun get-identifier () (get :identifier :value))
(defun get-number     () (get :number     :value))

;;; 読み込み補助関数群
(defun read-while (fn)    ; fn関数がfalseを返すまで、文字を読み込む
  (loop FOR c = (read-char) WHILE (funcall fn c) COLLECT c FINALLY (unread-char c)))

(defun read-identifier () ; 識別子を読み込む
  (coerce (read-while #'isalnum) 'string))

(defun read-number ()     ; 数値を読み込む(手抜き)
  (read-from-string (coerce (read-while #'isdouble) 'string)))

;;; トークン読み込み関数
(defun gettok ()        
  (cond ((isalpha (peek-char t))         ; 識別子 or キーワード
         (a.equal-case (read-identifier)
           ("def"     :def)              ;; 関数定義キーワード
           ("extern"  :extern)           ;; 関数宣言キーワード
           (otherwise (set-identifier it)
                      :identifier)))     ;; 識別子
                 
        ((isdouble (peek-char t))        ; 数値
         (set-number (read-number))
         :number)
                 
        ((char= #\# (peek-char t))       ; 一行コメント
         (read-line)
         (gettok))
        
        (t (read-char))))                ; その他の文字

;;; トークン読み込み関数2
;;; 　実際に他の箇所で使用されるのはこっち
;;; 　一番最後に読み込んだトークンを*curtok*に保持している
(defvar *curtok* nil)
(defun read-token ()
  (setf *curtok* (gettok)))

parser

次はparser。

;;; 抽象構文木(AST)の構成要素となる構造体(名前付きリスト)の定義
(defstruct (number-exp   (:type list) :named) val)         ; 数値式
(defstruct (variable-exp (:type list) :named) name)        ; 変数式
(defstruct (binary-exp   (:type list) :named) op lhs rhs)  ; 二項演算式
(defstruct (call-exp     (:type list) :named) callee args) ; 関数呼出式
(defstruct (prototype    (:type list) :named) name args)   ; プロトタイプ (関数名 + 引数名)
(defstruct (define       (:type list) :named) proto body)  ; 関数定義  ※ オリジナルではfunction(正確にはFunctionAST)となっているが、common-lispの組み込み関数と被るので、defineに変更

;;; 前方宣言と補助関数
;; 関数の前方宣言: 無くても平気。処理系によっては、定義/宣言を行わずに関数を呼び出すと警告が出るので、一応書いておく。
(declaim (ftype (function () t) parse-expression))

;; チェック関数
;; 現在ポイントしているトークンがvalでない場合に、エラーを送出する
;;  message: エラーメッセージ(本来あるべきトークンの名前)
;;  place:   エラー発生場所
;;  eat:     トークンが期待通りの場合に、これがtなら、そのトークンを読み捨てる
(defun expect (val &key message place eat)
  (let ((vs (if (listp val) val (list val))))
    (assert (member *curtok* vs) ()
            "Expected ~:[~{'~A'~^ or ~}~;~:*~A~*~]~@[ in ~A~] [~A]" message vs place *curtok*)
    (and eat (read-token))))

;;; パース関数群
(defun parse-number-exp ()
  (prog1 (make-number-exp :val (get-number))
    (read-token)))

(defun parse-paren-exp ()
  (prog2 (read-token) (parse-expression) (expect #\) :eat t)))

(defun parse-identifier-exp (&aux (id-name (get-identifier)))
  (if (not (eql #\( (read-token)))
      ;; 識別子の後に'('が続かない場合は、変数
      (make-variable-exp :name id-name)
    ;; ')'が続く場合は、関数呼出
    (make-call-exp 
     :callee id-name
     :args (if (eql #\) (read-token))   
               (progn (read-token) '()) ; 修正(2010/02/22): 関数呼び出しの引数が空の場合に、閉じ括弧を読み捨てるのを忘れていたのを修正
             (loop COLLECT (parse-expression)
                   WHILE (case *curtok*
                           (#\)       (read-token) nil)
                           (#\,       (read-token) t)
                           (otherwise (expect '(#\, #\)) :place "argument list"))))))))

(defun parse-primary ()
  (case *curtok*
    (:identifier (parse-identifier-exp))
    (:number     (parse-number-exp))
    (#\(         (parse-paren-exp))
    (otherwise   (error "Unknown token when expecting an expression [~A]" *curtok*))))

;; 演算子(及びその他の文字)の優先順位
(defun get-op-precedence ()
  (case *curtok*
    (#\< 10)         ; <
    (#\+ 20)         ; +
    (#\- 20)         ; -
    (#\* 40)         ; *
    (otherwise -1))) ; それ以外

;; 演算式をパースする
(defun parse-binop-rhs (exp-prec lhs)
  (do ((op-prec #1=(get-op-precedence) #1#)
       (op *curtok* *curtok*))
      ((< op-prec exp-prec) lhs)  ; 演算子(or トークン)の優先順位が、lhsのそれより低い場合は終了
    (read-token)
    (let ((rhs          (parse-primary))      ; 演算子の右側の式
          (next-op-prec (get-op-precedence))) ; 演算子の右側の式の右側の演算子(トークン)の優先順位
      (when (< op-prec next-op-prec)          ; 現在の演算子よりも、次の演算子の方が優先順位が高い場合は、そっちを先に読み込んでrhsにマージする
        (setf rhs (parse-binop-rhs (1+ op-prec) rhs)))
      ;; 演算式を作成する
      (setf lhs (make-binary-exp :op op :lhs lhs :rhs rhs)))))

(defun parse-expression ()
  (parse-binop-rhs 0 (parse-primary)))

(defun parse-prototype (&aux (fn-name (get-identifier)))
  (expect :identifier :message "function name" :place "prototype" :eat t)
  (let ((arg-names 
          (prog2 (expect #\( :place "prototype" :eat t)
                 (loop WHILE (eq *curtok* :identifier) COLLECT (prog1 (get-identifier) (read-token)))
                 (expect #\) :place "prototype" :eat t))))
    (make-prototype :name fn-name :args arg-names)))
      
(defun parse-definition ()
  (read-token)  ; "def"を読み捨てる
  (make-define :proto (parse-prototype)
               :body  (parse-expression)))

(defun parse-extern ()
  (read-token)  ; "extern"を読み捨てる
  (parse-prototype))

(defun parse-toplevel-exp ()
  ;; トップレベルの式は、無名関数定義で包む
  (make-define :proto (make-prototype :name "" :args '())
               :body  (parse-expression)))

;;; メインループ
;;; 　Kaleidoscopeの式を入力に受け取り、そのパース結果の抽象構文木を出力する
(defun main-loop (&optional (*print-pprint-dispatch* *print-pprint-dispatch*))
  (loop
   (princ "ready> ") (force-output)
   (handler-case
    (format t "~&~S~%"
      (case (read-token)
        (#\;       )  ; 式の終端
        (:def      (parse-definition))
        (:extern   (parse-extern))
        (otherwise (parse-toplevel-exp))))
    (end-of-file ()
      ;; ループ終了
      (return-from main-loop))
    (error (c)
      ;; エラー処理
      (read-token)
      (format *error-output* "~&Error: ~A~%" c)))))

実行例:

> (main-loop)

ready> 10;
(DEFINE (PROTOTYPE "" NIL) (NUMBER-EXP 10))

ready> (a+b)*2.4 < 3;
(DEFINE (PROTOTYPE "" NIL)
 (BINARY-EXP #\<
  (BINARY-EXP #\* (BINARY-EXP #\+ (VARIABLE-EXP "a") (VARIABLE-EXP "b"))
   (NUMBER-EXP 2.4))
  (NUMBER-EXP 3)))

ready> extern puts(str);
(PROTOTYPE "puts" ("str"))

ready> def foo(a b c) foo(a, c, 3.0) + b;
(DEFINE (PROTOTYPE "foo" ("a" "b" "c"))
 (BINARY-EXP #\+
  (CALL-EXP "foo" ((VARIABLE-EXP "a") (VARIABLE-EXP "c") (NUMBER-EXP 3.0)))
  (VARIABLE-EXP "b")))

ready> Ctrl+D  ; 終了

とりあえずここまでは問題無し。

感想

抽象構文木はほとんどlisp。