今回は電卓プログラムに論理演算子、比較演算子、条件分岐の機能を追加してみましょう。
論理演算子と比較演算子を使う場合、真偽値を表すデータが必要になります。電卓プログラムのデータは数値しかないので、Scheme の述語 zero? を満たすデータを偽、それ以外を真と定義することにしましょう。論理演算子と比較演算子は、結果が真であれば整数値 1 を、偽であれば整数値 0 を返すことにします。
電卓プログラムで使用する論理演算子と比較演算子を表に示します。
| 操作 | 意味 | トークン |
|---|---|---|
| not x, ! x | x の否定（真偽の反転） | not |
| x and y | x が真かつ y が真ならば真 | and |
| x or y | x が真まはた y が真ならば真 | or |
| 演算子 | 意味 | トークン |
|---|---|---|
| == | 等しい | == |
| != | 等しくない | != |
| < | より小さい | < |
| > | より大きい | > |
| <= | より小さいか等しい | <= |
| >= | より大きいか等しい | >= |
論理演算子は not (!), and, or で、not は単項演算子になります。比較演算子は ==, !=, <, >, <=, >= の 6 種類で、Ｃ言語の比較演算子と同じです。演算子の優先順位ですが、Ｃ言語のように細かく分けることはしないで、次のように設定することにしました。
優先順位 (高) 単項演算子 (+, -, not) 乗法演算子 (*, /) 加法演算子 (+, -) 比較演算子 (==, !=, <, >, <=, >=) 論理演算子 (and, or) 代入演算子 (=) 優先順位 (低)
条件分岐は「文」として定義することもできますが、今回は簡単な電卓プログラムなので「if 式」として組み込むことにします。if 式の構文を示します。
if 条件式 then 式a else 式b end if 条件式 then 式a end
if は条件式が真であれば式a を実行し、その結果が if 式の値になります。条件式が偽であれば 式b を実行して、その結果が if 式の値になります。else 節が省略されていて、かつ条件式が偽の場合、if 式は 0 を返すことにしましょう。
文法を EBNF で表すと次のようになります。
[EBNF]
文 = 関数定義 | 式.
関数定義 = "def", 関数, "(", [仮引数リスト], ")", 式, "end".
式 = 代入式 | 式１.
代入式 = 変数, "=", 式.
式１ = 式２, { ("and" | "or"), 式２}.
式２ = 式３, ("==" | "!=" | "<" | "<=" | ">" | ">="), 式３.
式３ = 項, { ("+" | "-"), 項 }.
項 = 因子, { ("*" | "/"), 因子 }.
因子 = 数値 | ("+" | "-" | "not"), 因子 | "(", 式, ")" | 変数 | 関数, "(", [引数リスト], ")" | if式.
if式 = "if", 式, "then", 式, ["else", 式], "end".
変数 = 識別子
関数 = 識別子
仮引数リスト = 変数, { ",", 変数 }.
引数リスト = 式, { ",", 式 }.
[注意] 数値と識別子の定義は省略
論理演算子と比較演算子の処理は、文法をそのままプログラムするだけなので簡単です。if 式は then 節または else 節をスキップする処理が必要になるので、プログラムはちょっと複雑になります。
それではプログラムを作りましょう。まず最初に、関数 get-token を修正します。
リスト : トークンの切り出し
(define (get-token)
;; 空白文字の読み飛ばし
(do ()
((not (char-whitespace? (getch))))
(nextch))
(cond ((char-numeric? (getch))
(set! *token* 'number)
(set! *value* (get-number)))
((char-alphabetic? (getch))
(set! *value* (get-ident))
(case *value*
((def end if then else not and or)
(set! *token* *value*))
(else
(set! *token* 'ident))))
(else
(case (getch)
((#\=)
(set! *token* '=)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '==)
(nextch)))
((#\+)
(set! *token* '+)
(nextch))
((#\-)
(set! *token* '-)
(nextch))
((#\*)
(set! *token* '*)
(nextch))
((#\/)
(set! *token* '/)
(nextch))
((#\()
(set! *token* 'lpar)
(nextch))
((#\))
(set! *token* 'rpar)
(nextch))
((#\<)
(set! *token* '<)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '<=)
(nextch)))
((#\>)
(set! *token* '>)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '>=)
(nextch)))
((#\!)
(set! *token* 'not)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '!=)
(nextch)))
((#\,)
(set! *token* 'comma)
(nextch))
((#\;)
(set! *token* 'semic)
(nextch))
((#\null)
(set! *token* 'eof))
(else
(set! *token* 'others))))))
識別子の処理で、*value* の値が def, end, if, then, else, not, and, or であれば、その値を *token* にセットします。それ以外の場合は ident をセットします。記号が = で、次の記号も = の場合は *token* にシンボル == をセットします。記号が ! の場合は *token* に not をセットし、次の記号が = であれば != に書き換えます。あとは同様に、<, <= と >, >= の処理を行います。
次は構文解析の処理を修正します。論理演算子の処理は次のようになります。
リスト : 論理演算子の処理
;;; 式
(define (expression)
(let ((val (expr1)))
(case *token*
((=)
;; 代入式の処理
(unless (symbol? val)
(error "invalid = form"))
(get-token)
(let ((val1 (eval-var (expression))))
(update-variable val val1)
val1))
(else val))))
;;; 論理演算子 (and と or の優先順位は同じとする)
(define (expr1)
(let loop ((val1 (expr2)))
(case *token*
((and)
(get-token)
(let ((val2 (expr2)))
(if (zero? (bitwise-and (eval-var val1) (eval-var val2)))
(loop 0)
(loop 1))))
((or)
(get-token)
(let ((val2 (expr2)))
(if (zero? (bitwise-ior (eval-var val1) (eval-var val2)))
(loop 0)
(loop 1))))
(else val1))))
式を評価する expression から関数 expr1 を呼び出します。expr1 は and と or の処理を行います。最初に、関数 expr2 を評価して返り値を val1 にセットします。次に、*token* が and または or の場合は、get-token を呼び出してから expr2 を評価して、返り値を val2 にセットします。and の場合、val1 と val2 の論理積が 0 でなければ、and の結果は 1 に、論理積が 0 であれば 0 になります。or の場合は論理和が 0 でなけれれば 1 に、論理和が 0 であれば 0 になります。
なお、and と or は短絡演算子といって、値が確定した時点でそれ以降の引数は評価されません。今回はプログラムを簡単にするため、すべての引数を評価しています。短絡演算子として実装する場合、値が確定した時点で残りの引数の処理をスキップする必要があります。ご注意くださいませ。
次は比較演算子の処理を作ります。
リスト : 比較演算子の処理
;;; 比較演算子の取得
(define (getcmp op)
(case op
((==) =)
((!=) (lambda (x y) (not (= x y))))
((<) <)
((<=) <=)
((>) >)
((>=) >=)
(else
(error "invalid operation:" op))))
;;; 比較演算子 (==, !=, <, <=, >, >= の優先順位は同じ)
(define (expr2)
(let ((val1 (expr3)))
(case *token*
((== != < <= > >=)
(let ((op *token*))
(get-token)
(if ((getcmp op) (eval-var val1) (eval-var (expr3)))
1
0)))
(else val1))))
(define (expr3)
(let loop ((val (term)))
(case *token*
((+)
(get-token)
(loop (eval-op + val (term))))
((-)
(get-token)
(loop (eval-op - val (term))))
(else val))))
関数 expr2 は比較演算子の処理を行います。比較演算子の定義は 式, 演算子, 式. なので、繰り返しは不要になります。最初に、expr3 を呼び出して左辺の式を評価し、その結果を val1 にセットします。次に、get-token を呼び出してから右辺の式を expr3 で評価して、その値と val1 を (getcmp op) で求めた関数で比較します。結果が真であれば 1 を、偽であれば 0 を返します。関数 expr3 は + と - の処理を行います。これは今までと同じです。
次は factor に not と if の処理を追加します。
リスト : 因子の処理
(define (factor)
(case *token*
((lpar)
(get-token)
(begin0
(expression)
(if (eq? *token* 'rpar)
(get-token)
(error "')' expected"))))
((number)
(begin0 *value* (get-token)))
((+)
;; 単項演算子
(get-token)
(eval-var (factor)))
((-)
;; 単項演算子
(get-token)
(- (eval-var (factor))))
((not)
(get-token)
(if (zero? (eval-var (factor)))
1
0))
((if)
(get-token)
(eval-if))
((ident)
(let ((func (lookup-function *value*)))
(cond (func
;; 関数呼び出し
(get-token)
(if (eq? *token* 'lpar)
(if (string? (cdr func))
(call-usrfunc (cdr func))
(apply (cdr func) (get-argument)))
(error "'(' expected")))
(else
;; 変数
(begin0 *value* (get-token))))))
(else
(error "unexpected token" *token*))))
not は 右辺を factor で評価して、その結果が 0 ならば 1 を、そうでなければ 0 を返します。if の処理は関数 eval-if で行います。
次は if 式を評価する関数 eval-if を作ります。
リスト : if の評価
(define (eval-if)
;; test の評価
(let ((result (eval-var (expression))))
(cond ((eq? *token* 'then)
(get-token)
(cond ((zero? result)
;; 偽
(skip-expression '(else end))
(cond ((eq? *token* 'else)
(get-token)
(let ((val (eval-var (expression))))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token)
val))
((eq? *token* 'end)
;; else 節は無し
(get-token)
0)
(else
(error "end expected"))))
(else
;; 真
(let ((val (eval-var (expression))))
(when (eq? *token* 'else)
(get-token)
(skip-expression '(end semic)))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token)
val))))
(else
(error "then expected")))))
最初に expression を呼び出して条件式を評価して返り値を変数 result にセットます。そのあと、*token* が then であることを確認します。そうでなければエラーを送出します。次に、result が 0 ならば else 節の処理を行います。関数 skip-expression で then 節の式をスキップして *token* をチェックします。
*token* が else であれば else 節が存在するので、その式を expression で評価します。そのあと、*token* が end であることを確認します。そうでなければエラーを送出します。それから、評価結果 val を返します。else 節がない場合は 0 を返します。
result が 0 でなければ then 節を expression で評価します。そのあと、*token* が else であれば else 節が存在するので、それを skip-expression でスキップします。次に、*token* が end であることを確認します。そうでなければエラーを送出します。最後に評価結果 val を返します。
次は式をスキップする処理を作ります。
リスト : スキップ処理
;;; if のスキップ
(define (skip-if)
;; 条件式をスキップ
(skip-expression '(then else end))
(unless (eq? *token* 'then)
(error "then expected"))
;; then 節をスキップ
(get-token)
(skip-expression '(else end))
(when (eq? *token* 'else)
(get-token)
;; else 節をスキップ
(skip-expression '(end)))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token))
;;; 式のスキップ
(define (skip-expression ends)
(let loop ()
(cond ((eq? *token* 'if)
;; if のスキップ
(get-token)
(skip-if)
(loop))
((not (member *token* ends))
(get-token)
(loop)))))
関数 skip-expression は引数 ends で指定されたトークンまでスキップします。if は式なので、入れ子にすることができます。このため、if 式をスキップする専用の関数 skip-if を用意し、*token* が if ならばその if 式まるごとスキップするようにします。
skip-if は if 式を解析しながらスキップしていきます。最初に条件式を skip-expression でスキップします。この場合、終端には then, else, end, を指定します。そのあと、*token* が then でなければエラーを送出します。次に、*token* が else であれば、終端に end を指定して else 節をスキップします。最後に *token* が end であることを確認し、get-token を呼び出して次のトークンを取り出します。これで if 式をスキップすることができます。
それでは簡単な実行例を示します。
Calc> not 0; => 1 Calc> not 1; => 0 Calc> ! 0; => 1 Calc> ! 1; => 0 Calc> 0 and 1; => 0 Calc> 1 and 1; => 1 Calc> 1 and 0; => 0 Calc> 0 and 0; => 0 Calc> 0 or 0; => 0 Calc> 0 or 1; => 1 Calc> 1 or 0; => 1 Calc> 1 or 1; => 1 Calc> 2 == 2; => 1 Calc> 2 == 1; => 0 Calc> 2 != 2; => 0 Calc> 2 != 1; => 1 Calc> 1 < 2; => 1 Calc> 1 <= 2; => 1 Calc> 2 <= 1; => 0 Calc> 2 > 1; => 1 Calc> 2 >= 1; => 1 Calc> 1 >= 2; => 0
論理演算子と比較演算子は正常に動作しているようです。次は論理演算子と比較演算子を組み合わせてみましょう。
Calc> not 1 or not 0; => 1 Calc> not 1 or not 1; => 0 Calc> not 0 or not 1; => 1 Calc> not 0 and not 0; => 1 Calc> not 0 and not 1; => 0 Calc> 1 < 2 and 2 < 3; => 1 Calc> 1 < 2 and 3 < 2; => 0 Calc> 1 < 2 or 3 < 2; => 1 Calc> 2 < 1 or 3 < 2; => 0
これも正常に動作しているようです。次は if 式を試してみましょう。
Calc> if 1 < 2 then 10 else -10 end; => 10 Calc> if 3 < 2 then 10 else -10 end; => -10 Calc> if 3 < 2 then 10 end; => 0 Calc> def abs(x) if x > 0 then x else -x end end; => abs Calc> abs(10); => 10 Calc> abs(-10); => 10 Calc> abs(10 - 11); => 1 Calc> abs(11 - 10); => 1
正常に動作していますね。条件分岐があると、再帰呼び出しで繰り返しを実現することができます。階乗を求める関数 fact とフィボナッチ数列を求める関数 fibo は次のようになります。
Calc> def fact(n) if n == 0 then 1 else n * fact(n - 1) end end; => fact Calc> fact(8); => 40320 Calc> fact(9); => 362880 Calc> fact(10); => 3628800 Calc> def fibo(n) if n == 0 or n == 1 then n else fibo(n - 1) + fibo(n - 2) end end; => fibo Calc> fibo(6); => 8 Calc> fibo(7); => 13 Calc> fibo(8); => 21 Calc> fibo(9); => 34 Calc> fibo(10); => 55 Calc> fibo(11); => 89
関数 fibo は二重再帰ですが、累積変数を使って末尾再帰に変換することができます。
Calc> def fiboi(n, a, b) if n == 0 then a else fiboi(n - 1, b, a + b) end end; => fiboi Calc> fiboi(6, 0, 1); => 8 Calc> fiboi(7, 0, 1); => 13 Calc> fiboi(8, 0, 1); => 21 Calc> fiboi(11, 0, 1); => 89
電卓プログラムは末尾再帰最適化を行わないので繰り返しに変換することはできませんが、二重再帰よりも高速にフィボナッチ数列を求めることができます。
今回はここまでです。次回は字句解析と構文解析の処理を分離して、複数の式を順番に実行する begin 式と、式を繰り返し実行する while 式を追加してみましょう。
;;;
;;; calc3.scm : 電卓プログラム (R7RS-small 対応版)
;;;
;;; (1) 変数と組み込み関数の追加
;;; (2) 関数定義の追加
;;; (3) 論理演算子、比較演算子を追加する
;;; if test then expr1 else expr2 end の追加
;;;
;;; Copyright (C) 2011-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme char) (scheme inexact)
(scheme bitwise) (scheme read) (scheme write))
;;;
;;; マクロ定義
;;;
;;; 多値は考慮しない簡略版
(define-syntax begin0
(syntax-rules ()
((_ a) a)
((_ a b ...) (let ((x a)) (begin b ...) x))))
;;; データの追加
(define-syntax push!
(syntax-rules ()
((_ place x) (set! place (cons x place)))))
;;; データの取得
(define-syntax pop!
(syntax-rules ()
((_ place)
(let ((x (car place)))
(set! place (cdr place))
x))))
;;;
;;; 大域変数
;;;
(define *ch* #f)
(define *token* #f)
(define *value* #f)
(define *input* (current-input-port))
;;;
;;; 関数
;;;
(define *function*
`((exp . ,exp)
(log . ,log)
(sin . ,sin)
(cos . ,cos)
(tan . ,tan)
(asin . ,asin)
(acos . ,acos)
(atan . ,atan)
(sqrt . ,sqrt)
(expt . ,expt)))
; 関数を求める
(define (lookup-function name)
(assoc name *function*))
;;;
;;; 変数
;;;
(define *variable* '())
; 変数の値を求める
(define (lookup-variable var)
(let ((cp (assoc var *variable*)))
(if cp
(cdr cp)
(error "unbound variable:" var))))
; 変数の値を更新する
(define (update-variable var val)
(let ((cp (assoc var *variable*)))
(if cp
(set-cdr! cp val)
(push! *variable* (cons var val)))))
;;;
;;; 入力処理
;;;
;;; 文字の読み込み
(define (nextch)
(set! *ch* (read-char *input*))
(when (eof-object? *ch*)
(set! *ch* #\null)))
;;; 先読み文字の取得
(define (getch) *ch*)
;;; 数値
(define (get-number)
(let ((buff '()))
;; 整数を buff に格納
(define (get-numeric)
(do ()
((not (char-numeric? (getch))))
(push! buff (getch))
(nextch)))
;; 整数部
(get-numeric)
(case (getch)
((#\.)
;; 小数部
(push! buff (getch))
(nextch)
(get-numeric)
(case (getch)
((#\d #\D #\e #\E)
;; 指数部
(push! buff (getch))
(nextch)
(when (or (eqv? (getch) #\+)
(eqv? (getch) #\-))
(push! buff (getch))
(nextch))
;; 指数の数字
(get-numeric))))
((#\/)
;; 分数
(push! buff (getch))
(nextch)
(get-numeric)))
(string->number (list->string (reverse buff)))))
;;; 識別子
(define (get-ident)
(let loop ((a '()))
(if (not (char-alphabetic? (getch)))
(string->symbol (list->string (reverse a)))
(let ((c (getch)))
(nextch)
(loop (cons c a))))))
;;; トークンの切り出し
(define (get-token)
;; 空白文字の読み飛ばし
(do ()
((not (char-whitespace? (getch))))
(nextch))
(cond ((char-numeric? (getch))
(set! *token* 'number)
(set! *value* (get-number)))
((char-alphabetic? (getch))
(set! *value* (get-ident))
(case *value*
((def end if then else not and or)
(set! *token* *value*))
(else
(set! *token* 'ident))))
(else
(case (getch)
((#\=)
(set! *token* '=)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '==)
(nextch)))
((#\+)
(set! *token* '+)
(nextch))
((#\-)
(set! *token* '-)
(nextch))
((#\*)
(set! *token* '*)
(nextch))
((#\/)
(set! *token* '/)
(nextch))
((#\()
(set! *token* 'lpar)
(nextch))
((#\))
(set! *token* 'rpar)
(nextch))
((#\<)
(set! *token* '<)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '<=)
(nextch)))
((#\>)
(set! *token* '>)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '>=)
(nextch)))
((#\!)
(set! *token* 'not)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '!=)
(nextch)))
((#\,)
(set! *token* 'comma)
(nextch))
((#\;)
(set! *token* 'semic)
(nextch))
((#\null)
(set! *token* 'eof))
(else
(set! *token* 'others))))))
;;;
;;; if の評価
;;;
;;; if のスキップ
(define (skip-if)
;; 条件式をスキップ
(skip-expression '(then else end))
(unless (eq? *token* 'then)
(error "then expected"))
;; then 節をスキップ
(get-token)
(skip-expression '(else end))
(when (eq? *token* 'else)
(get-token)
;; else 節をスキップ
(skip-expression '(end)))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token))
;;; 式のスキップ
(define (skip-expression ends)
(let loop ()
(cond ((eq? *token* 'if)
;; if のスキップ
(get-token)
(skip-if)
(loop))
((not (member *token* ends))
(get-token)
(loop)))))
;;; if の評価
(define (eval-if)
;; test の評価
(let ((result (eval-var (expression))))
(cond ((eq? *token* 'then)
(get-token)
(cond ((zero? result)
;; 偽
(skip-expression '(else end))
(cond ((eq? *token* 'else)
(get-token)
(let ((val (eval-var (expression))))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token)
val))
((eq? *token* 'end)
;; else 節は無し
(get-token)
0)
(else
(error "end expected"))))
(else
;; 真
(let ((val (eval-var (expression))))
(when (eq? *token* 'else)
(get-token)
(skip-expression '(end semic)))
(unless (eq? *token* 'end)
(error "end expected"))
(get-token)
val))))
(else
(error "then expected")))))
;;;
;;; 式の評価
;;;
;;; 変数の評価
(define (eval-var var)
(if (number? var)
var
(lookup-variable var)))
;;; 演算子の評価
(define (eval-op op var1 var2)
(op (eval-var var1) (eval-var var2)))
;;; 式
(define (expression)
(let ((val (expr1)))
(case *token*
((=)
;; 代入式の処理
(unless (symbol? val)
(error "invalid = form"))
(get-token)
(let ((val1 (eval-var (expression))))
(update-variable val val1)
val1))
(else val))))
;;; 論理演算子 (and と or の優先順位は同じとする)
(define (expr1)
(let loop ((val1 (expr2)))
(case *token*
((and)
(get-token)
(let ((val2 (expr2)))
(if (zero? (bitwise-and (eval-var val1) (eval-var val2)))
(loop 0)
(loop 1))))
((or)
(get-token)
(let ((val2 (expr2)))
(if (zero? (bitwise-ior (eval-var val1) (eval-var val2)))
(loop 0)
(loop 1))))
(else val1))))
;;; 比較演算子の取得
(define (getcmp op)
(case op
((==) =)
((!=) (lambda (x y) (not (= x y))))
((<) <)
((<=) <=)
((>) >)
((>=) >=)
(else
(error "invalid operation:" op))))
;;; 比較演算子 (==, !=, <, <=, >, >= の優先順位は同じとする)
(define (expr2)
(let ((val1 (expr3)))
(case *token*
((== != < <= > >=)
(let ((op *token*))
(get-token)
(if ((getcmp op) (eval-var val1) (eval-var (expr3)))
1
0)))
(else val1))))
(define (expr3)
(let loop ((val (term)))
(case *token*
((+)
(get-token)
(loop (eval-op + val (term))))
((-)
(get-token)
(loop (eval-op - val (term))))
(else val))))
;;; 項
(define (term)
(let loop ((val (factor)))
(case *token*
((*)
(get-token)
(loop (eval-op * val (factor))))
((/)
(get-token)
(loop (eval-op / val (factor))))
(else val))))
;;; 実引数の取得
(define (get-argument)
(get-token)
(if (eq? *token* 'rpar)
;; 引数無し
(begin (get-token) '())
(let loop ((a '()))
(let ((val (eval-var (expression))))
(case *token*
((rpar)
(get-token)
(reverse (cons val a)))
((comma)
(get-token)
(loop (cons val a)))
(else
(error "unexpected token in argument list" *token*)))))))
;;; 仮引数の取得
(define (get-parameter)
(get-token)
(unless (eq? *token* 'lpar)
(error "'(' expected"))
(get-token)
(let loop ((a '()))
(let ((val *value*))
(case *token*
((rpar)
(get-token)
(reverse a))
((ident)
(let ((val *value*))
(get-token)
(loop (cons val a))))
((comma)
(get-token)
(loop a))
(else
(error "unexpected token in parameter list" *token*))))))
;;; 変数束縛
(define (add-binding pars args)
(let loop ((pars pars) (args args))
(cond ((and (pair? pars) (pair? args))
(push! *variable* (cons (car pars) (car args)))
(loop (cdr pars) (cdr args)))
((and (pair? pars) (null? args))
(push! *variable* (cons (car pars) 0))
(loop (cdr pars) args)))))
;;; ユーザー関数の呼び出し
(define (call-usrfunc buff)
;; 環境の復帰
(define (restore-env xs)
(set! *input* (list-ref xs 0))
(set! *ch* (list-ref xs 1))
(set! *token* (list-ref xs 2))
(set! *value* (list-ref xs 3))
(set! *variable* (list-ref xs 4)))
(let ((args (get-argument)) ; 実引数の取得
(env (list *input* *ch* *token* *value* *variable*))) ; 環境の保存
(set! *input* (open-input-string buff))
(nextch)
(add-binding (get-parameter) args)
(with-exception-handler
(lambda (err) (restore-env env))
;; 本体の評価
(lambda ()
(let ((val (eval-var (expression))))
(unless (eq? *token* 'end) (error "end expected"))
(restore-env env)
val)))))
;;; 因子
(define (factor)
(case *token*
((lpar)
(get-token)
(begin0
(expression)
(if (eq? *token* 'rpar)
(get-token)
(error "')' expected"))))
((number)
(begin0 *value* (get-token)))
((+)
;; 単項演算子
(get-token)
(eval-var (factor)))
((-)
;; 単項演算子
(get-token)
(- (eval-var (factor))))
((not)
(get-token)
(if (zero? (eval-var (factor)))
1
0))
((if)
(get-token)
(eval-if))
((ident)
(let ((func (lookup-function *value*)))
(cond (func
;; 関数呼び出し
(get-token)
(if (eq? *token* 'lpar)
(if (string? (cdr func))
(call-usrfunc (cdr func))
(apply (cdr func) (get-argument)))
(error "'(' expected")))
(else
;; 変数
(begin0 *value* (get-token))))))
(else
(error "unexpected token" *token*))))
;;; ユーザー定義関数の本体を取得
(define (get-usrfunc)
(let loop ((a '()))
(if (eqv? (getch) #\;)
(begin0 (list->string (reverse (cons (getch) a)))
(nextch))
(let ((c (getch)))
(nextch)
(loop (cons c a))))))
;;; 値を表示する
(define (display-value value)
(display "=> ")
(display value)
(newline))
;;; 式の入力と評価
(define (toplevel)
(cond ((eq? *token* 'def)
;; 関数定義
(get-token)
(unless (eq? *token* 'ident)
(error "invalid def form"))
(let ((name *value*))
(push! *function* (cons name (get-usrfunc)))
(display-value name)))
(else
;; 式
(let ((val (eval-var (expression))))
(if (eq? *token* 'semic)
(display-value val)
(error "invalid token:" *token*)))))
(display "Calc> ")
(flush-output-port))
;;; 入力をクリアする
(define (clear-input-data)
(do ()
((eqv? *ch* #\newline))
(nextch))
(display "Calc> ")
(flush-output-port))
;;; 電卓プログラム
(define (calc)
(display "Calc> ")
(flush-output-port)
(nextch)
(call/cc
(lambda (break)
(let loop ()
(guard (err
(else (display "ERROR: ")
(display (error-object-message err))
(unless
(null? (error-object-irritants err))
(display (car (error-object-irritants err))))
(newline)
(clear-input-data)))
(get-token)
(when (eqv? *token* 'eof) (break #t))
(toplevel))
(loop)))))
;;; 実行
(calc)