lispで言語実装(2)

電卓の実装(2) 構文解析

1. 字句解析
2. 構文解析 ← いまここ
3. 意味解析

「1+2*3」の様な入力に対して、「(+ 1 (* 2 3))」を返す処理を作成する。
数式の構文規則は、以下の様に表現される。

E := T [["+" | "-"] T]*
T := F [["*" | "/"] F]*
F := NUM | "(" E ")"

この規則を、今回作成する構文解析器では以下のように指定する。

(setq E '(T (* (! "+" "-") T)))
(setq T '(F (* (! "*" "/") F)))
(setq F '((! NUM ("(" E ")"))))

記述方法は若干変えていて、["+" | "-"]は、(! "+" "-")のように記述するものとする(orの意味に!を用いるのは、xyzzylispでは|をシンボルに使えないため)。

コードは以下から。

(progn
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;; 字句解析
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq *src-stream nil); ソースとなるストリーム
  (setq unget-list nil); unget-tokenされたトークンを保存するリスト

  (defun set-src-stream(stm)
    ;ソースとなるストリームをセットする関数
    (setq *src-stream stm))

  (defun peek(st)
    ;ストリームを覗き見る関数。
    (let ((c (read-char st nil)))
      (if c
          (unread-char c st))
      c))
  
  (defun get-token()
    ;トークンを取得する関数。無い場合はnilを返す。
    (if (= 0 (length unget-list))
        (let ((c (read-char *src-stream nil)))
          (cond ((equal c nil) nil)
                ((digit-char-p c) (let ((res (digit-char-p c)) (next))
                                    (while (and (setq next (peek *src-stream)) (digit-char-p next))
                                      (setq res (+ (* res 10)
                                                   (digit-char-p (read-char *src-stream nil))))
                                      )
                                    res))
                ((char= c #\SPC)(get-token))
                ((char= c #\TAB)(get-token))
                ((char= c #\RET)(get-token))
                (t (format nil "~A" c))))
      (pop unget-list)))

  (defun unget-token(tok)
    ;トークンを差し戻す関数。
    (push tok unget-list))

  (defun peek-token()
    ;トークンを覗き見る関数。無い場合はnilを返す。
    (let ((tok (get-token)))
      (unget-token tok)
      tok))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;; 構文解析
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun stringmatch (rule-str)
    ;ルール上の文字列("+"とか)とトークンを比較する。同じならばトークンを返す。
    (if (equal rule-str (peek-token))
        (list (get-token))))

 
  (defun *func (rule)
    ;*記号を実現する。
    (!func (list (cons '+ rule) 'EMPTY)))
  
  (defun +func (rule)
    ;+記号を実現する。
    (let ((tree (&func rule)))
      (if tree
          (let ((resTree tree))
            (while (setq tree (callrule rule))
              (unless (eq 'empty tree)
                (setq resTree (append resTree tree))))
            resTree))))


  (defun make-node (in)
    ; 中置記法を前置記法に変換
    (defun make-node-sub (left op-rights)
      (if (equal nil op-rights)
          left
        (make-node-sub (list (first op-rights) left (second op-rights))
                       (cddr op-rights))))
    (list (make-node-sub (car in) (cdr in))))

  (defun callrule(match)
    (cond ((symbolp match) (if (listp (symbol-value match))
                               (funcall (gethash match action) (&func (symbol-value match)))
                             (funcall (symbol-value match))))
          ((stringp match) (stringmatch match))
          ((equal '+ (car match)) (+func (cdr match)))
          ((equal '* (car match)) (*func (cdr match)))
          ((equal '! (car match)) (!func (cdr match)))
          (t                      (&func match))))

  (defun !func (rulelist)
    ;|記号を実現する。
    (dolist (rule rulelist nil)
      (let ((tree (callrule (list rule))))
        (when tree
          (return tree)))))

  (defun &func (rulelist)
    ;|記号を実現する。
    (let ((tree (callrule (car rulelist)))) ; 先頭のルールを適応
      (when tree                            ; 結果(tree)が nil でない場合
        (let ((resTree tree))               ; resTree に代入
          (dolist (rule (cdr rulelist) resTree) ; 2番目以降のルールを適応するループ
            (setq tree (callrule rule))         ; ルール適応し、結果をtreeに代入。
            (cond ((equal tree nil) (throw 'label1 'sytax-error)) ; 結果が nil ならばエラー。
                  ((equal tree 'empty))                           ; 結果が emptyならば何もしない。
                  (t (setq resTree (append resTree tree)))))))))  ; それ以外ならば追加する。


  ;;; 文法定義
  (setq EMPTY (lambda() 'empty))
  (setq NUM   (lambda()
                (if (numberp (peek-token))
                    (list (get-token)))))
  
  (setq E '(T (* (! "+" "-") T)))
  (setq T '(F (* (! "*" "/") F)))
  (setq F '((! NUM ("(" E ")"))))

  (setq action (make-hash-table :test #'equal))
  (setf (gethash 'E action) (lambda (token-list)
                              (make-node token-list)))
  (setf (gethash 'T action) (lambda (token-list)
                              (make-node token-list)))
  (setf (gethash 'F action) (lambda (token-list)
                              (if (= 3 (length token-list))
                                  (list (second token-list))
                                (make-node token-list))))
  
  (defun parse(start)
    (make-node (callrule E)))

  (format t "start~%")
  (setq src "1 + 2 + 3 + 100 * 2")
  (set-src-stream (make-string-input-stream src))
  (setq s-tree (parse E))

  (format t "src: ~A~%" src)
  (format t "tree: ~A~%" s-tree)
  )

start
src: 1 + 2 + 3 + 100 * 2
tree: ((+ (+ (+ 1 2) 3) (* 100 2)))