今回は電卓プログラムに関数を定義する機能を追加してみましょう。
関数を定義するために、文法を次のように修正します。
[EBNF]
文 = 関数定義 | 式.
関数定義 = "def", 関数, "(", [仮引数リスト], ")", 式, "end".
式 = 代入式 | 式１.
代入式 = 変数, "=", 式.
式１ = 項, { ("+" | "-"), 項 }.
項 = 因子, { ("*" | "/"), 因子 }.
因子 = 数値 | ("+" | "-"), 因子 | "(", 式, ")" | 変数 | 関数, "(", [引数リスト], ")".
変数 = 識別子
関数 = 識別子
仮引数リスト = 変数, { ",", 変数 }.
引数リスト = 式, { ",", 式 }.
[注意] 数値と識別子の定義は省略
ユーザーが関数を定義するときは def ... end で行います。関数本体は関数名のあとの左カッコから入力の終わり (セミコロン) までを文字列に変換し、ペア (関数名 . 文字列) にまとめて大域変数 *function* に格納することにします。関数を実行する場合、そのつど文字列に字句解析と構文解析を適用することになります。このため、プログラムは少し複雑になります。なお、字句解析と構文解析の処理を分離して、字句解析の結果をリストに格納しておくと、プログラムはもっと簡単になります。これは回を改めて試してみましょう。
それではプログラムを作りましょう。最初に、記号の入力処理を修正します。
リスト : 記号の読み込み
;;; 入力ポート
(define *input* (current-input-port))
;;; 記号の読み込み
(define (nextch)
(set! *ch* (read-char *input*))
(when (eof-object? *ch*)
(set! *ch* #\null)))
入力ポートを切り替えるため、大域変数 *input* にセットされているポートから記号を読み込むように修正します。*input* は (current-input-port) の返り値 (標準入力) で初期化します。あとは nextch で read-char を評価するとき、入力ポートに *input* を指定するだけです。
次はトークンを切り分ける関数 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)
(set! *token* 'def))
((end)
(set! *token* 'end))
(else
(set! *token* 'ident))))
(else
(case (getch)
((#\=)
(set! *token* '=)
(nextch))
・・・省略・・・
(else
(set! *token* 'others))))))
識別子を取得するとき、get-ident の返り値が def ならば *token* にシンボル def を、end ならば *token* にシンボル end をセットします。それ以外の場合は、今までと同じくシンボル ident を *token* にセットします。
次は構文解析の処理を修正します。関数 factor でユーザー定義関数を呼び出す処理を追加します。
リスト : 因子の処理
(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))))
((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*))))
lookup-function で関数を求めて、その値を変数 func にセットします。関数の本体 (cdr func) が文字列であれば、それはユーザーが定義した関数です。call-usrfunc を呼び出して、(cdr func) を実行します。(cdr func) が文字列でなければ、組み込み関数を呼び出します。
次はユーザーが定義した関数を評価する call-usrfunc を作ります。
リスト : ユーザー関数の評価
(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)))))
最初に get-argument で実引数を取得してから、call-with-input-string で文字列ポートを生成し、ラムダ式の中で入力ポート *input* を文字列ポート in に切り替えます。関数の実行が終了したら、入力ポート *input* だけではなく大域変数 *ch*, *token*, *value*, *variable* の値も元に戻す必要があります。このため、これらの値を局所変数に退避しています。
その次に *input* の値をポート in に書き換えて、nextch で 1 記号先読みを行います。そして、関数 add-binding で変数束縛を行います。仮引数は get-parameter で取得します。変数束縛はペア (変数名 . 値) を *variable* の先頭に追加するだけです。この場合、引数の有効範囲はダイナミックスコープになります。それから expression を呼び出して関数本体の式を評価します。ここで、エラーが送出された場合でも、入力ポートや大域変数の値を元に戻さなければいけないことに注意してください。
このような処理は Common Lisp や Gauche に用意されいる unwind-protect と簡単なのですが、R7RS-small には定義されていません。そこで with-exception-handler を使うことにします。with-exception-handler の説明は拙作のページ「Scheme 入門: 例外」をお読みくださいませ。
局所変数 env に環境 (大域変数) の値を保存します。局所関数 restore-env は保存した環境を元に戻します。本体の評価で例外が送出された場合、with-exception-handler の第 1 引数が評価され、制御は上位の例外処理に移ります。ここで restore-env を呼び出せば、環境を元の値に戻すことができます。また、本体の処理が正常に終了した場合でも restore-env で環境を元に戻します。
次は実引数を取得する関数 get-argument を修正します。
リスト : 実引数の取得
(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*)))))))
ユーザー関数は引数がない場合も定義できるので、"(" ")" だけのときは空リストを返すように修正します。あとの処理は今までと同じです。
次は仮引数を取得する関数 get-parameter を作ります。
リスト : 仮引数の取得
(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*))))))
get-token で文字列ポートよりトークンを取り出し、それが左カッコ (lpar) であることをチェックします。それから、get-token で次のトークンを取り出し、識別子 ident であれば *value* の値を累積変数 a に追加します。右カッコ (rpar) の場合は累積変数 a を reverse で反転して返します。カンマ "," の場合はスキップするだけです。それ以外の場合はエラーを送出します。
次は変数束縛を行う関数 add-binding を作ります。
リスト : 変数束縛
(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)))))
変数束縛は、仮引数のリスト pars と実引数のリスト args の要素を取り出してペアを生成し、それを push! で大域変数 *variable* に追加していくだけです。関数の実行が終了すると、*variable* の値は元に戻されるので、追加された変数束縛は削除されることになります。
なお、pars の個数が args よりも多い場合、仮引数の値を 0 に初期化して実行することにします。args の個数が pars よりも多い場合、余った実引数は捨てることにしましょう。
最後に関数を定義する処理を toplevel に追加します。次のリストを見てください。
リスト : 式の入力と評価
(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))
*token* がシンボル def であれば関数定義文です。get-token で次のトークンを求め、それが ident でなければエラーを送出します。シンボルの場合は *value* に格納されたシンボルが関数名 name になります。あとは、関数本体を get-usrfunc で取り出して、name と関数本体 (文字列) をペアに格納して *function* にセットします。
関数 get-usrfunc は次のようになります。
リスト : ユーザー定義関数の本体を取得
(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))))))
セミコロンまで記号を読み込み、それを関数 list->string で文字列に変換するだけです。
それでは実行してみましょう。
Calc> def square(x) x * x end; => square Calc> square(10); => 100 Calc> square(1.234); => 1.522756 Calc> square(square(10)); => 10000 Calc> def add(x, y, z) x + y + z end; => add Calc> add(1, 2, 3); => 6 Calc> add(1, 2, 3, 4); => 6 Calc> add(1); => 1 Calc> add(square(2), square(5), square(8)); => 93
square は引数 x を 2 乗する関数です。square の引数で square を呼び出すこともできます。add は引数 x, y, z を足し算します。引数を 4 つ与えると、余分な引数は捨てられるので、合計値は 1 + 2 + 3 = 6 になります。また、実引数が少ない add(1) の場合、y と z は 0 に初期化されるので、返り値は 1 になります。add の引数で square や他の組み込み関数を呼び出すこともできます。
もうひとつ簡単な実行例を示しましょう。引数の有効範囲がダイナミックスコープになることを確認します。
Calc> a = 10; => 10 Calc> def foo() a end; => foo Calc> foo(); => 10 Calc> def bar(a) foo() end; => bar Calc> bar(100); => 100 Calc> a; => 10
変数 a に 10 をセットします。関数 foo は a の値を返しますが、仮引数に a はないので、foo() を実行すると大域変数の値 10 を返します。関数 bar は仮引数 a に値を受け取り、関数 foo を呼び出します。
ダイナミックスコープの場合、foo は関数 bar の引数 a にアクセスできるので、bar(100) を実行すると foo() は 100 を返すことになります。したがって、bar の返り値は 100 になります。もちろん、大域変数 a の値は 10 のままです。
今回はここまでです。次回は電卓プログラムに論理演算子、比較演算子、条件分岐の機能を追加してみましょう。
;;;
;;; calc2.scm : 電卓プログラム (R7RS-small 対応版)
;;;
;;; (1) 変数と組み込み関数の追加
;;; (2) 関数定義の追加
;;;
;;; Copyright (C) 2011-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme char) (scheme inexact)
(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)
(set! *token* 'def))
((end)
(set! *token* 'end))
(else
(set! *token* 'ident))))
(else
(case (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* 'comma)
(nextch))
((#\;)
(set! *token* 'semic)
(nextch))
((#\null)
(set! *token* 'eof))
(else
(set! *token* 'others))))))
;;;
;;; 式の評価
;;;
;;; 変数の評価
(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))))
(define (expr1)
(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))))
((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)