お気楽 Common Lisp プログラミング入門

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

今回は簡単な電卓プログラムを例題にして、「字句解析 (lexical analysis)」と「構文解析 (syntax analysys)」の基本的な手法について説明します。

●プログラミング言語処理系の基本的な構造

簡単な電卓プログラムといっても、基本的な構造はプログラミング言語の処理系 (インタプリタやコンパイラ) と大きな違いはありません。たとえばコンパイラの場合、次のような構造に分けることができます。

ソースコード -> [字句解析] -> [構文解析] -> [意味解析] -> [コード生成] -> 目的コード


                        図 : コンパイラの構造

字句解析は入力された文字を順番に調べて、名前、数値、予約語、演算子など、意味のある「かたまり (トークン : token)」に分解します。構文解析はトークンの並びが構文規則にあっているかチェックします。構文解析を行うプログラムのことを「パーサ (parser)」と呼びます。構文的には正しいプログラムでも、意味のうえでは間違っている場合があります。これをチェックするのが意味解析です。コード生成はターゲットマシンで実行するためのコード (機械語) を生成します。機械語ではなくアセンブリコードを出力するコンパイラも多いです。

インタプリタの場合、字句解析、構文解析、意味解析まではコンパイラとほとんど同じです。コードを生成するかわりに、プログラムを解釈して実行する処理が必要になります。最も原始的な方法は、ソースコートを読み込みながら逐次実行していくことです。この場合、字句解析、構文解析、意味解析を何度も繰り返し行うことになります。簡単な方法ですが、ループなどの繰り返しがある場合、無駄な処理が多くなるため実行速度は遅くなります。

もうひとつは、字句解析、構文解析、意味解析まで行った情報を何らかの形で保存しておき、それを解釈しながら実行していくことです。一般的には、解析して得られた情報は「構文木」という形で保存されます。また、プログラムを実行するための仮想マシンを用意し、そのマシンが直接実行できるコード (バイトコードなど) を生成する方法もあります。この場合、仮想マシンがコードを読み込みながら実行していくことになります。

今回作成する電卓プログラムは式を計算するだけの簡単なものなので、字句解析と構文解析ともに難しいところはほとんどありません。構文解析は「再帰降下法」を使うと簡単にプログラムできます。

●文法の表現

ほとんどのプログラミング言語は、「文脈自由文法 (context free grammer : CFG)」という方法で文法を定義することができます。文脈自由文法は「生成文法」と呼ばれる文法の一種で、文を生成する規則を定義し、その規則によって生成される文はその文法を満たしていると考えます。逆に、文法を満たしていない文は、その規則では生成することができない、ということになります。文脈自由文法は BNF (Backus Naur Form)、それを拡張した EBNF や構文図などで表すことができます。

ここで用語について簡単に説明します。「終端記号」は対象となるプログラミング言語で使用する記号のことで、BNF や EBNF では "..." で表します。「非端記号」は BNF や EBNF で用いる記号のことで、BNF では <...> で表します。

BNF の場合、構文規則は次の形式で表します。

非端記号 ::= 定義1 | 定義2 | ... | 定義n

ただし、| は「または」を表す。定義は終端記号や非端記号からなる。

簡単な例を示しましょう。a がいくつか並んだあとに b がいくつか並んだ記号列 (aa...bb...) を BNF であらわすと次のようになります。

<SeqAB> ::= <SeqA> <SeqB>
<SeqA>  ::= "a" | "a" <SeqA>
<SeqB>  ::= "b" | "b" <SeqB>

記号列を <SeqAB> とすると、a が並んだ記号列 <SeqA> のあとに b が並んだ記号列 <SeqB> が続けばいいので、定義は <SeqA> <SeqB> になります。<SeqA> は記号 "a" だけではなく "a" のあとに <SeqA> が続くパターンがあります。定義は "a" | "a" <SeqA> となります。<SeqB> も同様です。ここで、<SeqA> と <SeqB> は再帰的に定義されていることに注意してください。

この規則を適用することで、<SeqAB> を満たす任意の記号列を生成することができます。次の例を見てください。

<SeqAB> => <SeqA> <SeqB> => "a" <SeqA> <SeqB> => "a" "a" <SeqA> <SeqB>
 => "a" "a" "a" <SeqB> => "a" "a" "a" "b" <SeqB> => "a" "a" "a" "b" "b"

<SeqA> に定義 "a" <SeqA> を適用すると、"a" が一つ多い <SeqA> を生成することができます。定義 "a" を適用すると、そこで <SeqA> の生成は終了します。同様に <SeqB> の定義を適用することで記号列 <SeqB> を生成し、最終的には記号列 <SeqAB> を生成することができます。

文法が複雑になると BNF では読みにくくなることがあります。このような場合、EBNF を使うと便利です。EBNF で用いられる主な規則を示します。

非端記号は <...> で囲まない
::= のかわりに = を使う
非端記号や終端記号を並べる場合はカンマ , で区切る
規則の最後に記号 (セミコロンやピリオドなど) を付加する
{ α } : αの 0 回以上の繰り返し
[ α ] : αまたは空
( α ) : グループ化

EBNF で用いられる記号は正規表現と似ているので、正規表現がわかる方であれば EBNF を理解するのは難しくないでしょう。

<SeqAB> を EBNF で表すと次のようになります。

SeqAB = "a", { "a" }, "b", { "b" }.

BNF よりもわかりやすいと思います。

もうひとつ簡単な例を示しましょう。整数を EBNF で表すと、次のようになります。

整数       = ["+" | "-"], 無符号整数.
無符号整数 = 数字 | 非零数字, { 数字 }.
数字       = "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" | "0".
非零数字   = "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".

        図 : 整数の EBNF

整数は +, - の符号が付いた (または省略された) 無符号整数で表すことができます。無符号整数は数字が 1 桁の場合と、2 桁以上ある場合に分けられます。桁が複数ある場合、先頭が 0 以外の数字 (非零数字) で、そのあとに数字がいくつか続きます。あとは、非零数字と数字を定義するだけです。

●式の構文

次は数値と演算子 +, - *, / とカッコ ( ) を使った数式の構文を考えてみましょう。式は数値と演算子をつないだものです。演算子には優先順位があり、+, - よりも *, / の計算を先に行わなければなりません。そこで、*, / でつながれたものを「項 (term)」として定義することにします。すると、式は項を演算子 +, - でつないだものとして定義することができます。

次に項の定義について考えます。数値と演算子 *, / だけならば簡単ですが、カッコが出てきたら、その中を式として計算しなければなりません。そこで、演算子 *, / でつながれるものを「因子 (factor)」として定義します。そうすると、項は因子を演算子 *, / でつないだものとして定義することができます。最後に、因子を定義します。これは数値またはカッコで囲まれた式となります。

なお、演算子 +, -, *, / は左結合なので、同じ優先順位の演算子は左から順番に計算していくことに注意してください。この規則を BNF と EBNF で表すと次のようになります。

[BNF]
 <式>  ::= <項> | <式> "+" <項> | <式> "-" <項>
 <項>  ::= <因子> | <項> "*" <因子> | <項> "/" <因子>
<因子> ::= <数値> | "(" <式> ")"

[EBNF]
 式  = 項, { ("+" | "-"), 項 }.
 項  = 因子, { ("*" | "/"), 因子 }.
因子 = 数値 | "(", 式, ")".

[注意] 数値の定義は省略

たとえば、式 12 + 34 + 56 * 78 と (12 + 34 + 56) * 78 を構文木であらわすと、次のようになります。

構文木の場合、BNF の定義にそって構築すると簡単でわかりやすいでしょう。プログラムを作る場合は、EBNF の定義にそって行うと簡単です。EBNF で表した規則の左辺 (非端記号) を関数に割り当てます。右辺に出現する非端記号は対応する関数を呼び出します。終端記号は、正しい記号が現れていることを確認してそれを返します。選択 | は if や cond などで、{ } は繰り返しで表すことができます。

EBNF の定義が再帰的な構造になっているので、プログラムも再帰呼び出しの形になります。このような構文解析を「再帰降下法」と呼びます。具体的な説明はプログラムを作るところで行います。

●字句解析

それでは字句解析からプログラムを作っていきましょう。字句解析は入力ストリームから 1 記号ずつ読み取り、それをトークンに切り分けます。たとえば、数値を取得する場合、その数値が整数なのか実数なのか、また整数だとしてもそれが何桁あるのか、実際に記号を読み込んでみないとわかりません。このような場合、記号を先読みしておいて、それを大域変数に保存しておく方法がよく用いられます。

先読みした記号が数字であれば、さらに記号を読み込みます。そうでなければ、その記号を大域変数に保存しておいて、今まで読み込んだ記号から数値を生成します。そして、次の処理は大域変数に保存しておいた記号から始めればいいわけです。もちろん、記号を大域変数に保存しないで、記号を入力ストリームに戻す方法もあります。今回はオーソドックスに先読みした記号を大域変数に保存しておくことにしましょう。

記号を読み込むプログラムは次のようになります。

リスト : 記号の読み込み

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

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

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

スペシャル変数 *CH* に先読みした記号 (文字型データ) を格納します。切り分けたトークンは *TOKEN* に、数値は *VALUE* にセットします。関数 nextch は標準入力から read-char で 1 バイト読み込み、それを *CH* にセットします。関数 getch は *CH* の値を返すだけです。

トークンはシンボルで表します。下表にトークンで使用するシンボルを示します。

表 : トークン
シンボル	意味
NUMBER	数値
+, -, *, /	演算子
LPAR	左カッコ
RPAR	右カッコ
SEMIC	セミコロン
OTHERS	その他

セミコロン ';' は数式を入力するときの区切り記号として使います。電卓プログラムはセミコロンを見つけたら、入力された数式を計算して返します。式の最後には必ずセミコロンを入力してください。

トークンを切り分ける関数 get-token は次のようになります。

リスト : トークンの切り分け

;;; 空白文字の判定
(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)))
   (t
    (case (getch)
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

最初に loop で空白文字を読み飛ばします。空白文字の判定は述語 white-space-p で行います。述語 graphic-char-p は引数の文字が「図形 (表示) 文字」であれば真を返します。Common Lisp の場合、空白 (#\ ) も図形文字として扱われるので、述語 char= で空白のチェックをしています。この場合、改行文字も空白文字として認識されることに注意してください。

次に、述語 digit-char-p で先読みした記号が数字 (0 - 9) かチェックします。そうであれば、関数 get-number を呼び出して数値に変換し、返り値を *VALUE* にセットします。*TOKEN* にはシンボル NUMBER をセットします。それ以外の場合は (getch) の値で処理を分岐します。

#\+, #\-, #\*, #\- の場合は演算子なので、該当するシンボルを *TOKEN* にセットし、nextch で次の文字を読み込みます。#\( と #\) の場合はカッコを表すトークン LPAR, RPAR をセットします。#\; の場合はセミコロンを表すシンボル SEMIC をセットします。それ以外の場合はシンボル OTHERS をセットします。

次は数値を求める関数 get-number を作ります。

リスト : 数値を求める

;;; 数値用の文字か？
(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)))))

局所変数 buff に数値を表すデータを格納します。述語 number-char-p は数値用の文字を判定する述語です。0 - 9 の数字だけではなく、浮動小数点数で使用する文字 (#\. #\+ #\- #\d #\D) であれば真を返します。これらの文字が続く限り buff に格納します。そして、reverse で反転して concatenate で文字列に変換します。

Common Lisp で文字列を数に変換する場合、整数であれば関数 parse-integer がありますが、今回は浮動小数点数も扱いたいので、関数 read-from-string を使うことにします。

read-from-string string [eof-err [eof-value]] &key :start :end

read-from-string は read の文字列バージョンです。引数 string からデータを読み込んで S 式に変換します。キーワード引数 :start と :end で string の範囲を指定することもできます。返り値は変換した S 式と、まだ読み込んでいない文字の位置 (添字) です。

簡単な使用例を示します。

* (read-from-string "1234")

1234
4
* (read-from-string "1.234")

1.234
5
* (read-from-string "(a b c d)")

(A B C D)
9
* (read-from-string "a b c d")

A
2

read-from-string で buff からデータを読み込み、変換結果を変数 num にセットします。num が数値であれば num を返します。そうでなければ、error でエラーを通知します。

●構文解析

次は構文解析を作りましょう。字句解析と構文解析は別々に処理することも可能ですが、今回のプログラムでは構文解析を行う処理から関数 get-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)))
    (t
     (error "unexpected token ~a" *token*))))

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

;;; 式
(defun expression (&aux (val (term)))
  (loop
   (case
    *token*
    (+
     (get-token)
     (setq val (+ val (term))))
    (-
     (get-token)
     (setq val (- val (term))))
    (t
     (return val)))))

非端記号「式」に対応する関数が expression、「項」に対応する関数が term、「因子」に対応する関数が factor です。式の定義は EBNF で項, { ("+" | "-"), 項 } です。最初に term を呼び出して項の値を変数 VAL にセットします。{ } に対応するのが loop による繰り返しです。*TOKEN* が +, - の場合、get-token で次のトークンを求め、term を呼び出して次の項の値を求め、VAL と演算を行います。*TOKEN* が +, - 以外の場合は VAL を返します。

関数 term も EBNF の定義因子, { ("*" | "/"), 因子} と同じ処理になります。最初に factor を呼び出して、因子の値を変数 VAL にセットします。term と同様に { } に対応するのが loop による繰り返しです。*TOKEN* が *, / の場合は、get-token で次のトークンを求め、factor を呼び出して次の因子の値を求め、VAL と演算を行います。*TOKEN* が *, / 以外の場合は VAL を返します。

関数 factor も EBNF の定義数値 | "(" 式 ")" と同じ処理になります。*TOKEN* が LPAR (左カッコ) の場合、get-token で次のトークンを求めてから、expression を再帰呼び出しして式の値を求めます。次に、*TOKEN* の値が RPAR (右カッコ) であることをチェックします。右カッコがない場合はエラーを通知します。RPAR の場合は、get-token で次のトークンを求めてから VAL を返します。

*TOKEN* が NUMBER の場合は *VALUE* の値を返します。このとき、get-token で次のトークンを求めることに注意してください。*TOKEN* がそれ以外の値であればエラーを通知します。

●式の入力と評価

最後に式を入力して expression を評価する処理を作ります。次のリストを見てください。

リスト : 式の入力と評価

;;; 入力された式を評価する
(defun toplevel ()
  (let ((val (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) (c)
       (format t "ERROR: ~a~%" c)
       (clear-input-data)))))

関数 toplevel は expression を評価して入力された数式を計算します。そのあと、*TOKEN* がセミコロン (SEMIC) かチェックします。セミコロンであれば、expression の返り値 VAL を表示します。そうでなければ、入力された数式に誤りがあるのでエラーを通知します。関数 prompt はプロンプト "Calc> " を表示します。

関数 calc は電卓プログラムを実行します。まず最初にプロンプトを表示して、nextch で 1 記号先読みします。それから、loop で数式の "入力 - 評価 - 表示" を繰り返し行います。toplevel を呼び出すとき、get-token でトークンを求めておくことを忘れないでください。handler-case でエラーを捕捉した場合、format でエラーメッセージを表示して、関数 clear-input-date で入力されたデータをクリアします。

handler-case でエラーを指定する場合、(or simple-error arithmetic-error) とすると simple-error または arithmetic-error を捕捉することができます。

●実行例

それでは簡単な実行例を示します。

* (calc)
Calc> 1 - 2 + 3 * 4;
=> 11
Calc> (1 - 2 + 3) * 4;
=> 8
Calc> (1 - 2) * (3 + 4);
=> -7
Calc> 1.23456 * 1.111111;
=> 1.3717333
Calc> 1.23456 / 1.111111;
=> 1.1111041
Calc> 1.23456d0 * 1.111111d0;
=> 1.3717331961600001d0
Calc> 1.23456d0 / 1.111111d0;
=> 1.1111041111104112d0
Calc> 1 / 2;
=> 1/2
Calc> 1 / 2.0;
=> 0.5
Calc> 1 + 2 * -3;
ERROR: unexpected token -
Calc> 1 a 2;
ERROR: invalid token OTHERS
Calc> 1.2.1;
ERROR: invalid number 1.2.1
Calc> 1 / 0;
ERROR: arithmetic error DIVISION-BY-ZERO signalled
Operation was (/ 1 0).

このプログラムでは単項演算子 (+, -) をサポートしていないので、-3 を入力するとエラーになります。calc を終了するときは、CTRL-C または CTRL-D を入力してください。

●単項演算子の追加

次は、単項演算子の + と - を追加しましょう。文法は次のようになります。

[EBNF]
 式  = 項 { ("+" | "-"), 項 }.
 項  = 因子 { ("*" | "/"), 因子 }.
因子 = 数値 | ("+" | "-"), 因子 | "(" 式 ")".

[注意] 数値の定義は省略

因子の定義に ("+" | "-"), 因子を追加するだけです。これで +3 や -5 を処理することができます。プログラムは次のようになります。

リスト : 単項演算子の追加

(define (factor)
  (case *token*
    ((lpar)
     (get-token)
     (let ((val (expression)))
       (if (eq? *token* 'rpar)
           (get-token)
         (error "')' expected"))
       val))
    ((number)
     (begin0 *value* (get-token)))
    ((+)
     ; 単項演算子
     (get-token)
     (factor))
    ((-)
     ; 単項演算子
     (get-token)
     (- (factor)))
    (else
     (error "unexpected token:" *token*))))

因子で *token* が + の場合は、get-token のあとに factor を再帰呼び出しするだけです。- の場合は get-token のあとに (- (factor)) を評価するだけです。とても簡単ですね。

プログラムリスト１

●実行例 (2)

それでは簡単な実行例を示します。

* (calc)
Calc> -3;
=> -3
Calc> +3.14;
=> 3.14
Calc> 1 + 2 + -3;
=> 0
Calc> 1 + 2 + - 3 * - 4;
=> 15

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

●構文木の構築

ところで、今回のプログラムは構文解析といっしょに式も計算していますが、構文木を組み立ててから式を計算することもできます。字句解析は同じです。構文解析を行う関数 expression, term, factor は構文木を返すように修正します。そして、構文木を評価する関数 eval-expr を新しく作ります。

最初に構文木を定義します。

リスト :  構文木の定義

(defstruct op1 op rexpr)        ; 単項演算子
(defstruct op2 op lexpr rexpr)  ; 二項演算子

構造体 OP1 は単項演算子、OP2 は二項演算子を表します。スロット OP に演算子を表す関数をセットし、スロット LEXPR と REXPR には左辺式と右辺式を表す構文木セットします。なお、構文木には数値も含まれることに注意してください。

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

リスト : 構文解析

;;; 因子
(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)))
    (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 expression (&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)))))

関数 expression と term は、式を計算する処理を構文木を生成する関数 make-op2 に変更するだけです。関数 term は単項演算子の処理を関数 make-op1 に変更するだけです。

最後に、構文木を評価する関数 eval-expr を作ります。

リスト : 構文木の評価

(defun eval-expr (expr)
  (cond
   ((numberp expr) 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))))
   (t (error "invalid expression type ~a" expr))))

eval-expr は再帰を使えば簡単です。引数 EXPR が数値であれば、EXPR をそのまま返します。EXPR が演算子であれば、スロット OP に格納されている関数を呼び出します。このとき、eval-expr を再帰呼び出ししてスロット LEXPR, REXPR に格納されている構文木を評価して、スロット OP の関数に渡します。

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

●参考文献

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

●プログラムリスト１

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

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

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

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

;;; 数値用の文字か？
(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 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)))
   (t
    (case (getch)
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

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

;;; 因子
(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)))
    (t
     (error "unexpected token ~a" *token*))))

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

;;; 式
(defun expression (&aux (val (term)))
  (loop
   (case
    *token*
    (+
     (get-token)
     (setq val (+ val (term))))
    (-
     (get-token)
     (setq val (- val (term))))
    (t
     (return val)))))

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


;;; 入力された式を評価する
(defun toplevel ()
  (let ((val (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) (c)
       (format t "ERROR: ~a~%" c)
       (clear-input-data)))))

●プログラムリスト２

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

;;; 構文木
(defstruct op1 op rexpr)        ; 単項演算子
(defstruct op2 op lexpr rexpr)  ; 二項演算子

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

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

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

;;; 数値用の文字か？
(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 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)))
   (t
    (case (getch)
     ((#\+)
      (setq *token* '+)
      (nextch))
     ((#\-)
      (setq *token* '-)
      (nextch))
     ((#\*)
      (setq *token* '*)
      (nextch))
     ((#\/)
      (setq *token* '/)
      (nextch))
     ((#\()
      (setq *token* 'lpar)
      (nextch))
     ((#\))
      (setq *token* 'rpar)
      (nextch))
     ((#\;)
      (setq *token* 'semic)
      (nextch))
     (t
      (setq *token* 'others))))))

;;;
;;; 構文木の組み立て
;;;
(declaim (ftype (function () t) expression))

(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)))
    (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 expression (&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 eval-expr (expr)
  (cond
   ((numberp expr) 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))))
   (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) (c)
       (format t "ERROR: ~a~%" c)
       (clear-input-data)))))

Common Lisp Programming