Common Lisp Programming

電卓プログラムの作成 (後編)

前回は四則演算を行う簡単な電卓プログラムを作りました。今回は電卓プログラムに変数と関数の機能を追加してみましょう。

●変数

前回作成した電卓は、計算結果を表示したあとそれを保持していないので、計算結果を再利用することができません。一般の電卓のように、計算結果を記憶しておくメモリ機能があると便利です。この機能を「変数 (variable)」として実現することにします。プログラミング言語で言えば、大域変数 (グローバル変数) と同じ機能になります。

変数を実装するのであれば、変数に値を代入する操作が必要になります。文法に「文」を定義する、つまり「代入文」を追加する方法もありますが、今回は簡単な電卓プログラムなので、代入演算子 "=" を用意して式の中で処理することにしましょう。代入演算子は右辺の式の値を左辺の変数に代入するので、文法は次のように表すことができます。

[EBNF]
  式   = 代入式 | 式１.
代入式 = 変数, "=", 式.
 式１  = 項, { ("+" | "-"), 項 }.
  項   = 因子, { ("*" | "/"), 因子 }.
 因子  = 数値 | ("+" | "-"), 因子 | "(", 式, ")" | 変数.
 変数  = 識別子

[注意] 数値と識別子の定義は省略

演算子 = は他の演算子と違って右結合になることに注意してください。このため、他の演算子よりも優先順位を低くし、右辺の式の評価を優先して行います。そして、その結果を変数にセットします。文法では、式を 代入式 | 式１ に変更し、代入式で演算子 = の処理を行います。式１は今までの式の定義と同じです。これで演算子 = の優先順位を低くすることができます。あとは代入式の処理で、右辺の式を先に評価して、その結果を変数にセットすればいいわけです。

それから、因子に「変数」を追加します。変数の定義は「識別子」とし、識別子はアルファベットで構成されるものとします。電卓プログラムではそれをシンボルに変換し、シンボルを変数として扱います。なお、変数の値は因子の処理で求めると、代入式で左辺の変数が数値に変換されるため、右辺の値をセットすることができなくなります。そこで、因子の処理は変数を表すシンボルをそのまま返すことにします。変数の値は実際に演算を行うときに求めることにしましょう。

●関数

次は文法に関数を追加しましょう。関数の処理は「因子」に追加します。

[EBNF]
  式   = 代入式 | 式１.
代入式 = 変数, "=", 式.
 式１  = 項, { ("+" | "-"), 項 }.
  項   = 因子, { ("*" | "/"), 因子 }.
 因子  = 数値 | ("+" | "-"), 因子 | "(", 式, ")" | 変数 | 関数, "(", 引数リスト, ")".
 変数  = 識別子
 関数  = 識別子

引数リスト = 式, { ",", 式 }.

[注意] 数値と識別子の定義は省略

関数の名前は識別子とし、そのあとに引数をカッコで囲んで渡します。カッコの中は「引数リスト」として定義します。これは「式」をカンマで区切って並べたもので、一般的な手続き型言語の関数呼び出しと同じ形式になります。

ただし、変数と関数は同じ識別子なので、このままでは区別することができません。この場合、簡単な方法が 2 つあります。ひとつは関数として登録されている識別子を関数とする方法、もうひとつは次のトークンが左カッコ (lpar) であれば関数とする方法です。今回は前者の方法を採用することにしましょう。

●変数と関数の操作

それではプログラムを作ります。最初に、変数と関数を格納する大域変数とアクセス関数を定義します。次のリストを見てください。

リスト : 関数と変数のアクセス関数

;;; 組み込み関数
(defvar *primitive-function*
  `((exp  . ,#'exp)
    (log  . ,#'log)
    (sin  . ,#'sin)
    (cos  . ,#'cos)
    (tan  . ,#'tan)
    (asin . ,#'asin)
    (acos . ,#'acos)
    (atan . ,#'atan)
    (sqrt . ,#'sqrt)
    (expt . ,#'expt)))

;;; 関数を求める
(defun lookup-function (name)
  (assoc name *primitive-function*))

;;; 変数を格納する
(defvar *variable* '())

;;; 変数の値を求める
(defun lookup-variable (var)
  (let ((cp (assoc var *variable*)))
    (if cp
        (cdr cp)
      (error "unbound variable ~a" var))))

;;; 変数の値を更新する
(defun update-variable (var val)
  (let ((cp (assoc var *variable*)))
    (if cp
        (rplacd cp val)
      (push (cons var val) *variable*))))

組み込み関数はスペシャル変数 *PRIMITIVE-FUNCTION* に連想リストの形式で格納します。関数 lookup-function は名前が name の組み込み関数があるか *PRIMITIVE-FUNCTION* から探します。

変数はスペシャル変数 *VARIABLE* に連想リストの形式で格納します。関数 lookup-variable は *VARIABLE* から変数 VAR を探索します。見つからない場合はエラーを通知します。関数 update-variable は変数の値を更新します。変数 VAR が既に存在する場合は、replacd でその CDR 部の値を VAL に書き換えます。VAR が存在しない場合は、push で (cons var val) を *VARIABLE* に追加します。

●字句解析

次は関数 get-token を修正します。

リスト : 字句解析の修正

;;; 識別子
(defun get-ident ()
  (let (buff)
    (loop while (alpha-char-p (getch)) do (push (getch) buff) (nextch))
    (read-from-string (concatenate 'string (reverse buff)))))

;;; トークンの切り分け
(defun get-token ()
  ;; 空白文字の読み飛ばし
  (loop while (white-space-p (getch)) do (nextch))
  (cond
   ((digit-char-p (getch))
    (setq *token* 'number
          *value* (get-number)))
   ((alpha-char-p (getch))
    (setq *token* 'ident
          *value* (get-ident)))
   (t
    (case (getch)
     ((#\=)
      (setq *token* '=)
      (nextch))
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\,)
      (setq *token* 'comma)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

記号 (getch) がアルファベットの場合は関数 get-ident で識別子を切り分けます。*TOKEN* にはトークン IDENT をセットし、get-ident の返り値を *VALUE* にセットします。get-ident はアルファベットを変数 BUFF に格納し、それを文字列に変換したあと、read-from-string でシンボルに変換して返します。あとは、代入演算子 '=' とカンマ ',' が入力された場合、それを表すトークン = と COMMA を *TOKEN* にセットするだけです。

●構文解析

次は構文解析を修正します。まず最初に、代入演算子の処理を expression に追加します。次のリストを見てください。

リスト : expression の修正

;;; 変数の評価
(defun eval-var (var)
  (if (numberp var)
      var
    (lookup-variable var)))

;;; 演算子の評価
(defun eval-op (op var1 var2)
  (funcall op (eval-var var1) (eval-var var2)))

;;; 式 (加減算の処理)
(defun expr1 (&aux (val (term)))
  (loop
   (case
    *token*
    (+
     (get-token)
     (setq val (eval-op #'+ val (term))))
    (-
     (get-token)
     (setq val (eval-op #'- val (term))))
    (t
     (return val)))))

;;; 式
(defun expression (&aux (val (expr1)))
  (case *token*
   ((=)
    ;; 代入演算子の処理
    (unless (symbolp val)
      (error "invalid assignment form"))
    (get-token)
    (let ((val1 (eval-var (expression))))
      (update-variable val val1)
      val1))
   (t val)))

演算子 +, - の処理は関数 expr1 で行い、演算子 = の処理を expression で行います。expression は最初に expr1 を評価して、その返り値を変数 VAL にセットします。*TOKEN* が = の場合は代入式の処理を行います。

まず VAL の値をチェックして、シンボルでなければエラーを送出します。次に、expression を呼び出して右辺の式を評価して、返り値を関数 eval-var に渡して値を取得します。eval-var は引数が数値ならばそのまま返し、そうでなければ lookup-variable で変数の値を求めます。あとは、update-variable で変数の値を VAL1 に更新してから VAL1 を返します。

関数 expr1 は今までの expression と同じです。expr1 と term は演算子を評価するとき関数 eval-op を呼び出すように修正します。eval-op は引数を eval-var で評価してから演算子 OP を評価します。あとの処理は今までと同じです。関数 term も同じように修正します。

次は関数 factor を修正します。

リスト : 因子の修正

;;; 実引数の取得
(defun get-argument ()
  (get-token)
  (let ((a '()))
    (loop
     (let ((val (eval-var (expression))))
       (case *token*
        ((rpar)
         (get-token)
         (return (reverse (cons val a))))
        ((comma)
         (get-token)
         (push val a))
        (else
         (error "unexpected token in argument list ~a" *token*)))))))

;;; 因子
(defun factor ()
  (case *token*
    (lpar
     (get-token)
     (let ((val (expression)))
       (if (eq *token* 'rpar)
           (get-token)
         (error "')' expected"))
       val))
    (number
     (prog1 *value* (get-token)))
    (+
     ;; 単項演算子
     (get-token)
     (factor))
    (-
     ;; 単項演算子
     (get-token)
     (- (factor)))
    (ident
     (let ((func (lookup-function *value*)))
       (cond (func
              ;; 関数呼び出し
              (get-token)
              (if (eq *token* 'lpar)
                  (apply (cdr func) (get-argument))
                (error "'(' expected")))
             (t
              ;; 変数
              (prog1 *value* (get-token))))))
    (t
     (error "unexpected token ~a" *token*))))

*TOKEN* が IDENT の場合、変数または関数呼び出しの処理を行います。最初に lookup-function を呼び出し、識別子 *VALUE* が組み込み関数かチェックします。そうであれば、組み込み関数を呼び出します。引数の評価は関数 get-argument で行います。その前に、get-token を呼び出して次のトークンを求め、それが左カッコ (LPAR) であることを確認します。そうでなければエラーを通知します。組み込み関数でなければ変数なので、*VALUE* をそのまま返します。

get-argument はカンマで区切られた式を expression で評価し、その結果をリストに格納して返します。expression を評価したあと、case で *TOKEN* をチェックします。右カッコ (LPAR) であれば、式の値 VAL を累積変数 A に追加して reverse で反転して返します。カンマ (COMMA) であれば、まだ引数があるので次の式を評価します。そうでなければ、式に誤りがあるのでエラーを通知します。

あとは関数 toplevel で、expression の返り値を eval-var で評価する処理を追加するだけです。詳細は プログラムリスト１ をお読みください。

●実行例

それでは実行してみましょう。

* (calc)
Calc> a = 10;
=> 10
Calc> a;
=> 10
Calc> a * 10 + 20;
=> 120
Calc> b = a * 10 + 20;
=> 120
Calc> a + b;
=> 130
Calc> 1 + (c = 2 + 3 + 4) + 5 + 6;
=> 21
Calc> c;
=> 9
Calc> x = y = z = 0;
=> 0
Calc> x;
=> 0
Calc> y;
=> 0
Calc> z;
=> 0
Calc> p = p + 1;
ERROR: unbound variable P
Calc> q = 10;
=> 10
Calc> q;
=> 10
Calc> q = q + 1;
=> 11

変数に値を代入すると、その値を使って式を評価することができます。また、式の中に演算子 = が入っていても、その式を評価することができます。X = Y = Z = 0; のように、多重代入することも可能です。ただし、新しい変数 P で P = P + 1; のようなことはできません。Q = 10; を評価したあとならば、既に変数 Q は定義されているので、Q = Q + 1; は評価することができます。

次は組み込み関数を実行してみましょう。

Calc> sqrt(2);
=> 1.4142135
Calc> sqrt(2d0);
=> 1.4142135623730951d0
Calc> expt(2, 32);
=> 4294967296
Calc> PI = asin(0.5d0) * 6;
=> 3.1415926535897936d0
Calc> sin(0);
=> 0.0
Calc> sin(pi / 2);
=> 1.0d0
Calc> sin(pi);
=> -3.216245299353273d-16

正常に動作していますね。

●構文木の構築

変数や関数呼び出しは、構文木を構築してから処理することもできます。最初に、代入演算子と関数呼び出しに対応する構文木を定義します。

リスト :  構文木の定義

(defstruct op1 op  rexpr)        ; 単項演算子
(defstruct op2 op  lexpr rexpr)  ; 二項演算子
(defstruct agn var expr)         ; 代入演算子
(defstruct cal fn  args)         ; 関数呼び出し

構造体 AGN は代入演算子を表します。スロット VAR が左辺の変数、EXPR が右辺式です。構造体 CAL は関数呼び出しを表します。スロット FN が呼び出す関数、ARGS が FN に渡す引数です。なお、構文木には変数も含まれることに注意してください。

構文解析のプログラムは次のようになります。

リスト : 構文解析

;;; 因子
(defun factor ()
  (case *token*
    (lpar
     (get-token)
     (let ((val (expression)))
       (if (eq *token* 'rpar)
           (get-token)
         (error "')' expected"))
       val))
    (number
     (prog1 *value* (get-token)))
    (+
     ;; 単項演算子
     (get-token)
     (make-op1 :op #'+ :rexpr (factor)))
    (-
     ;; 単項演算子
     (get-token)
     (make-op1 :op #'- :rexpr (factor)))
    (ident
     (let ((func (lookup-function *value*)))
       (cond
        (func
         ;; 関数呼び出し
         (get-token)
         (if (eq *token* 'lpar)
             (make-cal :fn (cdr func) :args (get-argument))
           (error "'(' expected")))
        (t
         ;; 変数
         (prog1 *value* (get-token))))))
    (t
     (error "unexpected token ~a" *token*))))

;;; 式
(defun expression (&aux (val (expr1)))
  (case *token*
   (=
    ;; 代入演算子の処理
    (unless (symbolp val)
      (error "invalid assignment form"))
    (get-token)
    (make-agn :var val :expr (expression)))
   (t val)))

関数 factor では、関数呼び出しを処理するところで、関数 make-cal で構文木を生成して返します。関数 get-argument は構文木を格納したリストを返すように修正します。関数 expression では、代入演算子を処理するところで、関数 make-agn で構文木を生成して返します。

最後に、構文木を評価する関数 eval-expr を修正します。

リスト : 構文木の評価

(defun eval-expr (expr)
  (cond
   ((numberp expr) expr)
   ((symbolp expr)
    (lookup-variable expr))
   ((op2-p expr)
    (funcall (op2-op expr) (eval-expr (op2-lexpr expr)) (eval-expr (op2-rexpr expr))))
   ((op1-p expr)
    (funcall (op1-op expr) (eval-expr (op1-rexpr expr))))
   ((agn-p expr)
    (let ((val (eval-expr (agn-expr expr))))
      (update-variable (agn-var expr) val)
      val))
   ((cal-p expr)
    (apply (cal-fn expr)
           (mapcar (lambda (e) (eval-expr e)) (cal-args expr))))
   (t (error "invalid expression type ~a" expr))))

(symbolp expr) が真ならば、変数の値を関数 lookup-variable で求めます。(agn-p expr) が真ならば変数に値を代入します。eval-expr を再帰呼び出しして右辺式 (ang-expr expr) を評価し、その結果を変数 VAL にセットします。そして、関数 update-variable で変数の値を更新してから VAL を返します。

(cal-p expr) が真ならば関数 (cal-fn expr) を呼び出します。関数に渡す引数 (cal-args expr) は構文木なので、eval-expr を再帰呼び出しして値を求めます。この処理は mapcar を使えば簡単ですね。それから、apply で関数 (cal-fn expr) を呼び出して、その結果を返します。

あとの修正は簡単なので説明は割愛させていただきます。詳細は プログラムリスト２ をお読みください。興味のある方は実際にプログラムを動かして、いろいろ試してみてください。

●参考文献

1. 松田晋, 『実践アルゴリズム戦略 解法のテクニック 再帰降下型構文解析』, C MAGAZINE 1992 年 9 月号, ソフトバンク
2. 水野順, 『スクリプト言語を作ろう』, C MAGAZINE 2000 年 5 月号, ソフトバンク
3. 松浦健一郎, 『コンパイラの作成』, C MAGAZINE 2003 年 1 月号, ソフトバンク
4. 高田昌之, 『インタプリタ進化論』, ＣＱ出版社, 1992
5. 久野靖, 『言語プロセッサ』, 丸善株式会社, 1993

●プログラムリスト１

;;;
;;; calc1.lisp : 電卓プログラム
;;;
;;;              Copyright (C) 2020 Makoto Hiroi
;;;

;;; スペシャル変数
(defvar *ch*)
(defvar *token*)
(defvar *value*)

;;; 記号の読み込み
(defun nextch ()
  (setq *ch* (read-char)))

;;; 先読み記号の取得
(defun getch () *ch*)

;;; 組み込み関数
(defvar *primitive-function*
  `((exp  . ,#'exp)
    (log  . ,#'log)
    (sin  . ,#'sin)
    (cos  . ,#'cos)
    (tan  . ,#'tan)
    (asin . ,#'asin)
    (acos . ,#'acos)
    (atan . ,#'atan)
    (sqrt . ,#'sqrt)
    (expt . ,#'expt)))

;;; 関数を求める
(defun lookup-function (name)
  (assoc name *primitive-function*))

;;; 変数を格納する
(defvar *variable* '())

;;; 変数の値を求める
(defun lookup-variable (var)
  (let ((cp (assoc var *variable*)))
    (if cp
        (cdr cp)
      (error "unbound variable ~a" var))))

;;; 変数の値を更新する
(defun update-variable (var val)
  (let ((cp (assoc var *variable*)))
    (if cp
        (rplacd cp val)
      (push (cons var val) *variable*))))

;;; 数値用の文字か？
(defun number-char-p (c)
  (or (digit-char-p c)
      (find c '(#\. #\+ #\- #\d #\D))))

;;; 数値を求める
(defun get-number ()
  (let (buff)
    (loop while (number-char-p (getch)) do (push (getch) buff) (nextch))
    (setq buff (concatenate 'string (reverse buff)))
    (multiple-value-bind
     (num len)
     (read-from-string buff)
     (if (and (numberp num) (= (length buff) len))
         num
       (error "invalid number ~a~%" buff)))))

;;; 識別子
(defun get-ident ()
  (let (buff)
    (loop while (alpha-char-p (getch)) do (push (getch) buff) (nextch))
    (read-from-string (concatenate 'string (reverse buff)))))

;;; 空白文字の判定
(defun white-space-p (c)
  (or (char= c #\ )
      (not (graphic-char-p c))))

;;; トークンの切り分け
(defun get-token ()
  ;; 空白文字の読み飛ばし
  (loop while (white-space-p (getch)) do (nextch))
  (cond
   ((digit-char-p (getch))
    (setq *token* 'number
          *value* (get-number)))
   ((alpha-char-p (getch))
    (setq *token* 'ident
          *value* (get-ident)))
   (t
    (case (getch)
     ((#\=)
      (setq *token* '=)
      (nextch))
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\,)
      (setq *token* 'comma)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

;;;
;;; 式の評価
;;;
(declaim (ftype (function () t) expression))

;;; 変数の評価
(defun eval-var (var)
  (if (numberp var)
      var
    (lookup-variable var)))

;;; 演算子の評価
(defun eval-op (op var1 var2)
  (funcall op (eval-var var1) (eval-var var2)))

;;; 実引数の取得
(defun get-argument ()
  (get-token)
  (let ((a '()))
    (loop
     (let ((val (eval-var (expression))))
       (case *token*
        ((rpar)
         (get-token)
         (return (reverse (cons val a))))
        ((comma)
         (get-token)
         (push val a))
        (else
         (error "unexpected token in argument list ~a" *token*)))))))

;;; 因子
(defun factor ()
  (case *token*
    (lpar
     (get-token)
     (let ((val (expression)))
       (if (eq *token* 'rpar)
           (get-token)
         (error "')' expected"))
       val))
    (number
     (prog1 *value* (get-token)))
    (+
     ;; 単項演算子
     (get-token)
     (factor))
    (-
     ;; 単項演算子
     (get-token)
     (- (factor)))
    (ident
     (let ((func (lookup-function *value*)))
       (cond (func
              ;; 関数呼び出し
              (get-token)
              (if (eq *token* 'lpar)
                  (apply (cdr func) (get-argument))
                (error "'(' expected")))
             (t
              ;; 変数
              (prog1 *value* (get-token))))))
    (t
     (error "unexpected token ~a" *token*))))

;;; 項
(defun term (&aux (val (factor)))
  (loop
   (case
    *token*
    (*
     (get-token)
     (setq val (eval-op #'* val (factor))))
    (/
     (get-token)
     (setq val (eval-op #'/ val (factor))))
    (t
     (return val)))))

;;; 式 (加減算の処理)
(defun expr1 (&aux (val (term)))
  (loop
   (case
    *token*
    (+
     (get-token)
     (setq val (eval-op #'+ val (term))))
    (-
     (get-token)
     (setq val (eval-op #'- val (term))))
    (t
     (return val)))))

;;; 式
(defun expression (&aux (val (expr1)))
  (case *token*
   ((=)
    ;; 代入演算子の処理
    (unless (symbolp val)
      (error "invalid assignment form"))
    (get-token)
    (let ((val1 (eval-var (expression))))
      (update-variable val val1)
      val1))
   (t val)))

;;; プロンプトの出力
(defun prompt ()
  (format t "Calc> ")
  (force-output))

;;; 入力された式を評価する
(defun toplevel ()
  (let ((val (eval-var (expression))))
    (cond
     ((eq *token* 'semic)
      (format t  "=> ~a~%" val)
      (prompt))
     (t
      (error "invalid token ~a" *token*)))))

;;; 入力をクリアする
(defun clear-input-data ()
  (loop while (not (eql *ch* #\Newline)) do (nextch))
  (prompt))

;;; 電卓の実行
(defun calc ()
  (prompt)
  (nextch)
  (loop
   (handler-case
       (progn (get-token) (toplevel))
     ((or simple-error arithmetic-error program-error) (c)
       (format t "ERROR: ~a~%" c)
       (clear-input-data)))))

●プログラムリスト２

;;;
;;; calct1.lisp : 電卓プログラム (構文木)
;;;
;;;               Copyright (C) 2020 Makoto Hiroi
;;;

;;; 構文木
(defstruct op1 op  rexpr)        ; 単項演算子
(defstruct op2 op  lexpr rexpr)  ; 二項演算子
(defstruct agn var expr)         ; 代入演算子
(defstruct cal fn  args)         ; 関数呼び出し

;;; スペシャル変数
(defvar *ch*)
(defvar *token*)
(defvar *value*)

;;; 記号の読み込み
(defun nextch ()
  (setq *ch* (read-char)))

;;; 先読み記号の取得
(defun getch () *ch*)

;;; 組み込み関数
(defvar *primitive-function*
  `((exp  . ,#'exp)
    (log  . ,#'log)
    (sin  . ,#'sin)
    (cos  . ,#'cos)
    (tan  . ,#'tan)
    (asin . ,#'asin)
    (acos . ,#'acos)
    (atan . ,#'atan)
    (sqrt . ,#'sqrt)
    (expt . ,#'expt)))

;;; 関数を求める
(defun lookup-function (name)
  (assoc name *primitive-function*))

;;; 変数を格納する
(defvar *variable* '())

;;; 変数の値を求める
(defun lookup-variable (var)
  (let ((cp (assoc var *variable*)))
    (if cp
        (cdr cp)
      (error "unbound variable ~a" var))))

;;; 変数の値を更新する
(defun update-variable (var val)
  (let ((cp (assoc var *variable*)))
    (if cp
        (rplacd cp val)
      (push (cons var val) *variable*))))

;;; 数値用の文字か？
(defun number-char-p (c)
  (or (digit-char-p c)
      (find c '(#\. #\+ #\- #\d #\D))))

;;; 数値を求める
(defun get-number ()
  (let (buff)
    (loop while (number-char-p (getch)) do (push (getch) buff) (nextch))
    (setq buff (concatenate 'string (reverse buff)))
    (multiple-value-bind
     (num len)
     (read-from-string buff)
     (if (and (numberp num) (= (length buff) len))
         num
       (error "invalid number ~a~%" buff)))))

;;; 識別子
(defun get-ident ()
  (let (buff)
    (loop while (alpha-char-p (getch)) do (push (getch) buff) (nextch))
    (read-from-string (concatenate 'string (reverse buff)))))

;;; 空白文字の判定
(defun white-space-p (c)
  (or (char= c #\ )
      (not (graphic-char-p c))))

;;; トークンの切り分け
(defun get-token ()
  ;; 空白文字の読み飛ばし
  (loop while (white-space-p (getch)) do (nextch))
  (cond
   ((digit-char-p (getch))
    (setq *token* 'number
          *value* (get-number)))
   ((alpha-char-p (getch))
    (setq *token* 'ident
          *value* (get-ident)))
   (t
    (case (getch)
     ((#\=)
      (setq *token* '=)
      (nextch))
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\,)
      (setq *token* 'comma)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

;;;
;;; 構文木の構築
;;;
(declaim (ftype (function () t) expression))

;;; 実引数の取得
(defun get-argument ()
  (get-token)
  (let ((a '()))
    (loop
     (let ((val (expression)))
       (case *token*
        ((rpar)
         (get-token)
         (return (reverse (cons val a))))
        ((comma)
         (get-token)
         (push val a))
        (else
         (error "unexpected token in argument list ~a" *token*)))))))

;;; 因子
(defun factor ()
  (case *token*
    (lpar
     (get-token)
     (let ((val (expression)))
       (if (eq *token* 'rpar)
           (get-token)
         (error "')' expected"))
       val))
    (number
     (prog1 *value* (get-token)))
    (+
     ;; 単項演算子
     (get-token)
     (make-op1 :op #'+ :rexpr (factor)))
    (-
     ;; 単項演算子
     (get-token)
     (make-op1 :op #'- :rexpr (factor)))
    (ident
     (let ((func (lookup-function *value*)))
       (cond
        (func
         ;; 関数呼び出し
         (get-token)
         (if (eq *token* 'lpar)
             (make-cal :fn (cdr func) :args (get-argument))
           (error "'(' expected")))
        (t
         ;; 変数
         (prog1 *value* (get-token))))))
    (t
     (error "unexpected token ~a" *token*))))

;;; 項
(defun term (&aux (val (factor)))
  (loop
   (case
    *token*
    (*
     (get-token)
     (setq val (make-op2 :op #'* :lexpr val :rexpr (factor))))
    (/
     (get-token)
     (setq val (make-op2 :op #'/ :lexpr val :rexpr (factor))))
    (t
     (return val)))))

;;; 式 (加減算の処理)
(defun expr1 (&aux (val (term)))
  (loop
   (case
    *token*
    (+
     (get-token)
     (setq val (make-op2 :op #'+ :lexpr val :rexpr (term))))
    (-
     (get-token)
     (setq val (make-op2 :op #'- :lexpr val :rexpr (term))))
    (t
     (return val)))))

;;; 式
(defun expression (&aux (val (expr1)))
  (case *token*
   (=
    ;; 代入演算子の処理
    (unless (symbolp val)
      (error "invalid assignment form"))
    (get-token)
    (make-agn :var val :expr (expression)))
   (t val)))

;;; 構文木の評価
(defun eval-expr (expr)
  (cond
   ((numberp expr) expr)
   ((symbolp expr)
    (lookup-variable expr))
   ((op2-p expr)
    (funcall (op2-op expr) (eval-expr (op2-lexpr expr)) (eval-expr (op2-rexpr expr))))
   ((op1-p expr)
    (funcall (op1-op expr) (eval-expr (op1-rexpr expr))))
   ((agn-p expr)
    (let ((val (eval-expr (agn-expr expr))))
      (update-variable (agn-var expr) val)
      val))
   ((cal-p expr)
    (apply (cal-fn expr)
           (mapcar (lambda (e) (eval-expr e)) (cal-args expr))))
   (t (error "invalid expression type ~a" expr))))

;;; プロンプトの出力
(defun prompt ()
  (format t "Calc> ")
  (force-output))

;;; 入力された式を評価する
(defun toplevel ()
  (let ((expr (expression)))
    (cond
     ((eq *token* 'semic)
      (format t  "=> ~a~%" (eval-expr expr))
      (prompt))
     (t
      (error "invalid token ~a" *token*)))))

;;; 入力をクリアする
(defun clear-input-data ()
  (loop while (not (eql *ch* #\Newline)) do (nextch))
  (prompt))

;;; 電卓の実行
(defun calc ()
  (prompt)
  (nextch)
  (loop
   (handler-case
       (progn (get-token) (toplevel))
     ((or simple-error arithmetic-error program-error) (c)
       (format t "ERROR: ~a~%" c)
       (clear-input-data)))))