読者です 読者をやめる 読者になる 読者になる

Packrat Parsing: 遅延版

common lisp algorithm

前回の実装ではメモ化をハッシュテーブルを用いて実装していたが、それを論文*1に合わせて遅延実行を利用するものに修正。
こっちの方が(あらかじめ入力テキストの各位置に対して、遅延されたパーサ関数実行を用意しておく必要があるが)メモ化によって既に計算済みの値のチェックが、eq関数の呼び出し一つで行えるので効率が良い。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 遅延評価用のマクロと関数の定義
;; 式の実行を遅延
(let ((undef (gensym)))
  (defmacro delay (exp)
    `(let ((#1=#:result ',undef))
       (lambda ()
         (if (eq #1# ',undef)  ; #:resultの値が初期値と等しいかをチェック
             (setf #1# ,exp)   ; 等しいならexpを実行して、#:resultに結果を保存
           #1#)))))            ; #:resultに以前の実行結果が格納されているなら、それを返す
 
;; 遅延された式の評価
(defun force (exp)
  (if (functionp exp)
      (funcall exp)
    exp))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; パーサ定義補助関数等
;;; 以下三つは前回と同じ
;; 範囲外アクセス時に#\Nullを返すchar関数
(defun char* (s i)
  (or (ignore-errors (char s i)) #\Null))

;; 式(リスト)が'(return ...)形式かどうかを判定する
(defun return-exp-p (exp) (and (listp exp) (eq (car exp) 'return)))
(deftype return-exp () '(satisfies return-exp-p))

;; 与えられた引数を文字列として連結し、シンボルに変換して返す
(defun symb (&rest args)
  (intern 
   (with-output-to-string (out)
     (dolist (a args) (princ a out)))))

;; パーサ定義補助用マクロ
;; 基本的な構造は前回と同じ
;; 異なる点:
;;  - 入力が文字列の変わりにderivs構造体(入力テキストの各文字をノードとする連結リストの一種)
;;  - 他のパース結果の参照は、パーサ関数を直接呼び出す代わりに、derivs構造体のフィールドに格納されている遅延されたパース処理を評価することで行う
(defmacro with-parser ((input) &body tokens)
  (labels
   ((recur (tokens)
      (destructuring-bind (token . rest) tokens
        (etypecase token
          (string
           `(and (char= ,(char token 0) (derivs-char ,input))
                 (let ((,input (derivs-next ,input)))  
                   ,(recur rest))))
          (return-exp
           `(list t ,(second token) ,input))
          (list
           (destructuring-bind (var <- parser) token
             (declare (ignore <-))
             `(destructuring-bind (#1=#:succeed? ,var ,input)
                                  (force (,(symb 'derivs- parser) ,input))
                (and #1# ,(recur rest)))))))))
   (recur tokens)))
;; derivs構造体 ※ 'derivs'は論文によれば'derivations'の略
(defstruct derivs
  char       ; 入力テキストの現在位置の文字
  next       ; 次の位置(derivs構造体)へのリンク

  additive   ; 現在位置に対するadditive関数の遅延された実行
  multitive  ; 現在位置に対するmultitive関数の遅延された実行
  primary    ; 現在位置に対するprimary関数の遅延された実行
  decimal)   ; 現在位置に対するdecimal関数の遅延された実行
;;;;;;;;;;;
;;;; パーサ
(defun parse (s)
  (force (derivs-additive (parse-impl s)))) 

(defun parse-impl (s)
  (let ((d (make-derivs :char (char* s 0))))  ; 現在位置の文字を設定してderivsインスタンスを生成
    (with-slots (additive multitive primary decimal char next) d
      (setf additive  (delay (additive d))    ; (additive d)を遅延
            multitive (delay (multitive d))   ; (multitive d)を遅延
            primary   (delay (primary d))     ; (primary d)を遅延
            decimal   (delay (decimal d)))    ; (decimal d)を遅延

      (when (plusp (length s))  ; 入力テキストの次の位置も同様に処理する
        (setf next (parse-impl (subseq s 1)))))
    d))

;; parse-implは入力文字列を、derivsインスタンスの連結リストに変換する
(parse-impl "lisp")
--> #S(DERIVS :ADDITIVE #<CLOSURE (LAMBDA #) {B056165}> :MULTITIVE #<CLOSURE (LAMBDA #) {B05617D}> :PRIMARY #<CLOSURE (LAMBDA #) :DECIMAL #<CLOSURE (LAMBDA #) {B0561AD}>{B056195}>
        :CHAR #\l  ; "l"
        :NEXT 
        #S(DERIVS :ADDITIVE #<CLOSURE # {B056205}> :MULTITIVE #<CLOSURE # {B05621D}> :PRIMARY #<CLOSURE # {B056235}> :DECIMAL #<CLOSURE # {B05624D}>
            :CHAR #\i  ; "i"
            :NEXT 
            #S(DERIVS :ADDITIVE # :MULTITIVE # :PRIMARY # :DECIMAL #
                :CHAR #\s  ; "s"
                :NEXT
                #S(DERIVS :ADDITIVE # :MULTITIVE # :PRIMARY # :DECIMAL #
                    :CHAR #\p  ; "p"
                    :NEXT 
                    #S(DERIVS :ADDITIVE # :MULTITIVE # :PRIMARY # :DECIMAL #
                        :CHAR #\Nul  ; 終端文字
                        :NEXT NIL)))))

;; 以下、additive/multititve/primary、の定義は引数名を変更した以外は、前回と同様
(defun additive (drv)
  (labels ((alt1 ()
             (with-parser (drv)
               (v1 <- multitive)
               "+"
               (v2 <- additive)
               (return (+ v1 v2))))
           (alt2 ()
             (with-parser (drv)
               (v1 <- multitive)
               "-"
               (v2 <- additive)
               (return (- v1 v2))))
           (alt3 ()
             (multitive drv)))
    (or (alt1)
        (alt2)
        (alt3))))

(defun multitive (drv)
  (labels ((alt1 ()
             (with-parser (drv)
               (v1 <- primary)
               "*"
               (v2 <- multitive)
               (return (* v1 v2))))
           (alt2 ()
             (with-parser (drv)
               (v1 <- primary)
               "/"
               (v2 <- multitive)
               (return (/ v1 v2))))
           (alt3 ()
             (primary drv)))
    (or (alt1)
        (alt2)
        (alt3))))

(defun primary (drv)
  (labels ((alt1 ()
             (with-parser (drv)
               "("
               (v <- additive)
               ")"
               (return v)))
           (alt2 ()
             (decimal drv)))
    (or (alt1)
        (alt2))))

(defun decimal (drv)
  (with-slots (char next) drv
    (or (and (char<= #\0 char #\9)
             (list t (- (char-code char) (char-code #\0)) next))
        (list nil nil drv))))

実行例

(parse "1+2")
--> (T 3 #S(DERIVS :ADDITIVE #<CLOSURE # {B066885}>         
                   :MULTITIVE #<CLOSURE # {B06689D}>
                   :PRIMARY #<CLOSURE # {B0668B5}>
                   :DECIMAL #<CLOSURE # {B0668CD}>
                   :CHAR #\Nul
                   :NEXT NIL))

(parse "4*2-((3+1)-(9/3))*2")
--> (T 6 #S(DERIVS :ADDITIVE #<CLOSURE # {B06AC2D}>
                   :MULTITIVE #<CLOSURE # {B06AC45}>
                   :PRIMARY #<CLOSURE # {B06AC5D}>
                   :DECIMAL #<CLOSURE # {B06AC75}>
                   :CHAR #\Nul
                   :NEXT NIL))

;; 不正な入力文字列: 二文字目以降のパースに失敗
(parse "4**2-3/5")
--: (T 4
     #S(DERIVS
         :ADDITIVE #<CLOSURE # {B06CB0D}>
         :MULTITIVE #<CLOSURE # {B06CB25}>
         :PRIMARY #<CLOSURE # {B06CB3D}>
         :DECIMAL #<CLOSURE # {B06CB55}>
         :CHAR #\*
         :NEXT 
         #S(DERIVS
             :ADDITIVE #
             :MULTITIVE #
             :PRIMARY #
             :DECIMAL #
             :CHAR #\*
             :NEXT #S(DERIVS
                      :ADDITIVE #
                      :MULTITIVE #
                      :PRIMARY #
                      :DECIMAL #
                      :CHAR #\2
                      :NEXT #S(DERIVS
                               :ADDITIVE #
                               :MULTITIVE #
                               :PRIMARY #
                               :DECIMAL #
                               :CHAR #\-
                               :NEXT #S(DERIVS
                                        :ADDITIVE #
                                        :MULTITIVE #
                                        :PRIMARY #
                                        :DECIMAL #
                                        :CHAR #\3
                                        :NEXT #S(DERIVS
                                                 :ADDITIVE #
                                                 :MULTITIVE #
                                                 :PRIMARY #
                                                 :DECIMAL #
                                                 :CHAR #\/
                                                 :NEXT #S(DERIVS
                                                          :ADDITIVE #
                                                          :MULTITIVE #
                                                          :PRIMARY #
                                                          :DECIMAL #
                                                          :CHAR #\5
                                                          :NEXT #S(DERIVS
                                                                   :ADDITIVE #
                                                                   :MULTITIVE #
                                                                   :PRIMARY #
                                                                   :DECIMAL #
                                                                   :CHAR #\Nul
                                                                   :NEXT NIL)))))))))