lispで言語実装(4)

電卓の実装(4) 番外編

前回までのコードでは、「-1+2」の様な計算ができない。本当は字句解析で「-1」というトークンを返すようにするのがいいのかもしれないが、せっかくBNFで構文解析を記述できるようにしたので、Fの定義を以下のように変更して対応してみる。

変更前: (setq F '((! NUM ("(" E ")")))) 
変更後: (setq F '((! NUM ((! "-" "+") NUM) ("(" E ")"))))

構文解析時に「-1」を(- 0 1)に展開するようにする。

実際に動作するコードは以下から。

(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 F '((! NUM ((! "-" "+") 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)
                              (cond ((= 3 (length token-list)) (list (second token-list)))
                                    ((= 2 (length token-list)) (list (list (first token-list) 0 (second token-list))))
                                    (t (make-node token-list)))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;; 意味解析
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun eval-tree(tree)
    (if (atom tree)
        tree
      (if (= 1 (length tree))
          (eval-tree (car tree))
        (cond ((equal (car tree) "+") (+ (eval-tree (second tree))
                                         (eval-tree (third tree))))
              ((equal (car tree) "-") (- (eval-tree (second tree))
                                         (eval-tree (third tree))))
              ((equal (car tree) "*") (* (eval-tree (second tree))
                                         (eval-tree (third tree))))
              ((equal (car tree) "/") (/ (eval-tree (second tree))
                                         (eval-tree (third tree))))))))

  (defun parse(start)
    (make-node (callrule E)))

  (format t "start~%")
  (setq src "(-1+2)*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)
  (format t "ans: ~A~%" (eval-tree s-tree))
  )