M.Hiroi's Home Page

Functional Programming

お気楽 Scheme プログラミング入門

[ PrevPage | Scheme | NextPage ]

関数型電卓プログラム fncalc の作成

今回は電卓プログラムをベースに、簡単なインタプリタ型のプログラミング言語 fncalc を作りましょう。

今回作成する fncalc はプログラムを仮想マシン用のコードにコンパイルしてから実行します。Lisp / Scheme の場合、SECD マシンをベースに仮想マシンを構築すると、インタプリタ型のプログラミング言語は簡単に作ることができます。SECD マシンについては、拙作のページ Scheme 入門: micro Scheme コンパイラの作成 をお読みください。

今回は SECD マシンを使うのですから、電卓プログラムに匿名関数 (クロージャ) の機能を追加することにします。クロージャをサポートすると、効率を度外視すれば簡単なデータ構造、たとえば「連結リスト」を作ることも可能です。そのあとで、「末尾再帰最適化」と「継続」の機能を追加してみましょう。

●fncalc の文法

EBNF で fncalc の文法を表すと次のようになります。

[EBNF]
  文    = def文 | 実行文.
 def文  = "def", 識別子, "(", [仮引数リスト], ")", block文.
実行文  = begin文 | if文 | while文 | let文 | 式文.
begin文 = "begin", block文.
 if文   = "if", 式, "then", 文, ["else", 文], "end".
while文 = "while", 式, "do", block文.
 let文  = "let", 代入式1, {",", 代入式1}, "in", block文.
block文 = 実行文, {実行文}, "end".
 式文   = 式, ";".

  式    = 代入式 | 式1.
代入式  = 変数, "=", 式.
代入式1= 変数, "=", 式1.
 式1   = 式2, { ("and" | "or"), 式2}.
 式2   = 式3, ("eq" | "==" | "!=" | "<" | "<=" | ">" | ">="), 式3.
 式3   = 項, { ("+" | "-"), 項 }.
  項    = 因子, { ("*" | "/" | "%"), 因子 }.
 因子   = 定数 | ("+" | "-" | "not"), 因子 | "(", 式, ")" | 変数 | fn式 |
          変数, "(", [引数リスト], ")" | fn式, "(", [引数リスト], ")".
 fn式   = "fn", "(", [仮引数リスト], ")", block文.
 変数   = 識別子
 定数   = 数値 | 文字列

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

[注意] 数値, 識別子, 文字列の定義は省略

電卓プログラムと異なり、文法は「文」を中心に定義します。文は関数を定義する def 文と、実際にプログラムで実行する「実行文」の 2 つがあります。実行文は begin 文、if 文、while 文、let 文、式文からなります。let 文は局所変数を定義します。let と in の間にある変数が局所変数になります。block 文は複数の実行文を並べたもので、begin, def, while, let の本体が block 文になります。式文は式を文にしたもので、式の後ろにセミコロンを付けます。これで block 文の中で式を記述することができます。

式の文法は電卓プログラムとほとんど同じです。新しい演算子として剰余を求める % 演算子と Scheme の eqv? と同じ働きをする eq 演算子を追加します。fncalc は Scheme と同様に関数の本体を変数に格納します。変数の後ろに "(" がある場合を関数呼び出しとしてコンパイルすることにします。匿名関数は fn 式で表します。fn 式はクロージャを生成します。fn 式の後ろに "(" を付けると、fn 式で生成したクロージャを呼び出すことができます。

一般に、文は式と違って値を持つことはありませんが、今回はプログラムを簡単にするため、fncalc の実行文は値を返すことにします。if 文は then 節または else 節の値を、begin 文と let 文は、block 文で最後に実行した文の値を返します。while 文は 0 を返し、式文は式の値を返します。

fncalc の簡単なプログラム例を示します。

リスト : fncalc のプログラム例

# 階乗 (再帰定義)
def fact(n)
  if n == 0 then
    1;
  else
    n * fact(n - 1);
  end
end

# 階乗 (繰り返し)
def facti(n)
  let a = 1 in
    while n > 0 do
      a = a * n;
      n = n - 1;
    end
    a;
  end
end

# フィボナッチ関数 (二重再帰)
def fibo(n)
  if n == 0 or n == 1 then
    n;
  else
    fibo(n - 1) + fibo(n - 2);
  end
end

# フィボナッチ関数 (末尾再帰)
def fiboi(n, a, b)
  if n == 0 then
    a;
  else
    fiboi(n - 1, b, a + b);
  end
end

# フィボナッチ関数 (繰り返し)
def fibol(n)
  let a = 0, b = 1 in
    while n > 0 do
      let c = a in
        a = b;
        b = b + c;
        n = n - 1;
      end
    end
    a;
  end
end

fncalc は # から改行までをコメントとして扱います。プログラムの内容はとくに難しいところはないでしょう。

●fncalc 用の SECD マシン

fncalc で追加 (変更) した SECD マシンの命令について簡単に説明します。

●算術演算子

(a b . s) e (op . c) d => ((op b a) . s) e c d

op は算術演算子 +, -, *, /, % に対応する命令で、算術演算子と同じ記号を用います。スタックから 2 つの引数を取り出し、演算した結果をスタックに追加します。

●比較演算子

(a b . s) e (op . c) d => ((if (op b a) 1 0) . s) e c d

op は比較演算子 eq, ==, !=, <, <=, >, >= に対応する命令で、比較演算子と同じ記号を用います。スタックから 2 つの引数を取り出し、演算した結果が真であれば 0 を、偽であれば 1 をスタックに追加します。

●論理演算子

(a b . s) e (op . c) d => ((if (zero? (func b a)) 0 1) . s) e c d
func = bitwise-and ; and の場合
func = bitwise-ior ; or の場合

op は論理演算子 and, or に対応する命令で、論理演算子と同じ記号を用います。スタックから 2 つの引数を取り出し、演算した結果が 0 であれば 0 を、それ以外であれば 1 をスタックに追加します。

●単項演算子

(a . s) e (op . c) d => (v . s) e c d
v = (- a)              ; neg の場合
v = (if (zero? a) 1 0) : not の場合

neg は単項演算子 - に対応する命令です。スタックから引数 a を取り出し、(- a) の結果をスタックに追加します。not は単項演算子 not (!) に対応する命令です。スタックから引数 a を取り出し、a が 0 ならば 1 を、そうでなければ 0 をスタックに追加します。

●bgn, whl, rpt

bgn, whl, rpt は while 文による繰り返しを実現するための命令です。while 文は次のようにコンパイルされます。

while 条件式 do 本体 end => (bgn 条件式のコード whl (本体のコード rpt) 次のコード)

SECD マシンの動作は次のようになります。

s e (bgn . c1) d => s e c1 (c1 . d)
(v . s) e (whl code . c2) (c1 . d) => s e code (c1 . d) ; v が 0 以外の場合
                                   => (v . s) e c2 d    ; v が 0 の場合
s e (rpt . c) (c1 . d) => s e c1 (c1 . d)

bgn は条件式の開始位置を d に格納します。これが rpt でのジャンプ先になります。whl はスタックトップの値 v が 0 以外の場合、while 文の本体 code を実行します。0 の場合はダンプ d からジャンプ先 c1 を取り除いて、while 文の次のコード c2 を実行します。rpt はダンプ d からジャンプ先 c1 を求めて、コード c を c1 に変更するだけです。このとき、ダンプ d から c1 を取り除いていはいけません。

なお、bgn, whl, rpt の動作はプログラミング言語 Forth の制御構造を参考にしました。

●ldg

ldg は大域変数の値を求めてスタックトップに追加する命令です。

s e (ldg (sym . val) . c) d => (val . s) e c d

今までは大域変数を表す連想リスト *global-environment* から sym の値を求めていましたが、fncalc ではコンパイル時に大域変数とその値を格納するペア (sym . val) を求めてコードにセットすることにしました。コンパイル時に大域変数 sym が存在しない場合は、そのときにペア (sym . 0) を生成して *global-environment* に追加することにします。

●式のコンパイル

それではプログラムを作りましょう。式のコンパイルですが、基本的には中置記法 a op b を後置記法 a b op に変換するだけなので簡単です。あとは、fn 式と関数呼び出し、代入式の処理を fncalc の文法に合わせて作るだけです。因子を処理する関数 factor は次のようになります。

リスト :  因子の処理

(define (factor env)
  (case *token*
    ((lpar)
     (get-token)
     (begin0
      (expression env)
      (if (eq? *token* 'rpar)
          (get-token)
          (compile-error "')' expected"))))
    ((number)
     (begin0 (list 'ldc *value*) (get-token)))
    ((string)
     (begin0 (list 'ldc *value*) (get-token)))
    ((not)
     (get-token)
     (append (factor env) (list 'not)))
    ((+)
     ;; 単項演算子 (+ をはずすだけ)
     (get-token)
     (factor env))
    ((-)
     ;; 単項演算子
     (get-token)
     (append (factor env) (list 'neg)))
    ((fn)
     ;; クロージャの生成
     (let ((code (list 'ldf
                       (append (compile-block (cons (get-parameter) env))
                               (list 'rtn)))))
       (get-token)
       (if (eq? *token* 'lpar)
           ;; 関数呼び出し
           (append (compile-argument env) code (list 'app))
         code)))
    ((ident)
     (let ((code #f)
           (pos (location *value* env)))
       (if pos
           ;; 局所変数
           (set! code (list 'ld pos))
         ;; 大域変数
         (set! code (list 'ldg (get-gvar *value*))))
       (get-token)
       (if (eq? *token* 'lpar)
           ;; 関数呼び出し
           (append (compile-argument env) code (list 'app))
         ;; 変数
         code)))
    (else
     (compile-error "unexpected token"))))

factor の引数 env は局所変数の環境を表します。*token* が lpar の場合は expression を呼び出して式をコンパイルします。number と string の場合は定数をスタックに積む命令 ldc にコンパイルします。単項演算子 + は + を省くだけです。not は (factor) のあとに命令 not を、単項演算子 - は (factor) のあとに命令 neg を追加します。

*token* が fn の場合はクロージャを生成する命令 ldf にコンパイルします。fn 式の本体を関数 compile-block でコンパイルします。このとき、局所変数の環境 env に fn 式の仮引数を追加します。仮引数は関数 get-paramter で求めます。本体コードの最後には命令 rtn を付け加えます。

次のトークンが lpar の場合、生成したクロージャを呼び出すコードにコンパイルします。実引数を評価するコートを関数 compile-argument で生成します。そのあとがクロージャを生成するコード code になり、最後が関数を呼び出す命令 app になります。トークンが lpar でない場合は code をそのまま返します。

*token* が ident の場合は変数の値を求めるコードにコンパイルします。局所変数の環境 env に変数 *value* があるか関数 get-lvar でチェックします。局所変数がある場合は ld 命令に、そうでなければ ldg 命令にコンパイルします。大域変数は関数 get-gvar で求めます。このとき、大域変数が存在しない場合は、この時点で大域変数とその値を表すペアを生成して、環境 *global-environment* に追加します。

次のトークンが lpar の場合は変数の値を関数呼び出しするコードにコンパイルします。実引数を評価するコートを関数 compile-argument で生成します。そのあとが変数の値を求めるコード code になり、最後が関数を呼び出す命令 app になります。トークンが lpar でない場合は code をそのまま返します。

次は代入式の処理を行う関数 expression を作ります。

リスト : 式のコンパイル

(define (expression env)
  (let ((val (expr1 env)))
    (case *token*
      ((=)
       (get-token)
       (case (car val)
         ((ld)
          ;; 局所変数の代入
          (append (expression env) (list 'lset (cadr val))))
         ((ldg)
          ;; 大域変数の代入
          (append (expression env) (list 'gset (cadr val))))
         (else
          (compile-error "invalid assignment form"))))
      (else val))))

引数 env は局所変数を表す環境です。*tokne* が = で、(car val) が ld の場合は値を局所変数に代入します。ldg の場合は大域変数に代入します。それぞれ、式を評価するコードを expression で生成し、そのあと ld, ldg を lset, gset に置き換えます。これで変数に値を代入することができます。

あとは文法に従って式を処理するプログラムを作るだけです。詳細は プログラムリスト をお読みください。

●文のコンパイル

次は文をコンパイルする関数 compile を作りましょう。

リスト : コンパイル

(define (compile)
  (cond ((eq? *token* 'def)
         ;; 関数定義
         (get-token)
         (unless (eq? *token* 'ident)
           (compile-error "invalid def form"))
         (let ((name *value*)
               (code (append (compile-block (list (get-parameter)))
                             (list 'rtn))))
           (list 'ldf code 'gset (get-gvar name))))
        (else
         (compile-statement '()))))

compile は *token* が def ならば関数をコンパイルして、そのコードを大域変数に格納します。そうでなければ、関数 compile-statement を呼び出して実行文をコンパイルします。関数定義は簡単です。関数名を name にセットし、関数本体を compile-block でコンパイルします。このとき、仮引数を get-parameter で取り出して compile-block に渡します。def 文で関数を定義するとき、局所変数の環境は仮引数しかありません。あとは ldf code でクロージャを生成して、それを gset で大域変数 name にセットするだけです。

次は実行文をコンパイルする関数 compile-statement を作ります。

リスト : 実行文のコンパイル

(define (compile-statement env)
  (case *token*
    ((begin)
     (get-token)
     (compile-block env))
    ((if)
     (get-token)
     (compile-if env))
    ((while)
     (get-token)
     (compile-while env))
    ((let)
     (get-token)
     (compile-let env))
    (else
     ;; 式文
     (begin0
       (expression env)
       (unless (eq? *token* 'semic)
         (compile-error "';' expected"))))))

begin 文は関数 compile-block で、if 文は関数 compile-if で、while 文は関数 compile-while で、let 文は関数 compile-let でコンパイルします。それ以外の場合は式文とみなして expression でコンパイルします。式文の場合、最後にセミコロンが付いていることを確認します。そうでなければ関数 compile-error でエラーを送出します。

●if 文のコンパイル

次は if 文をコンパイルする関数 compile-if を作ります。SECD マシンの場合、if 文のコードは次のようになります。

(条件式のコード sel (then節のコード join) (else節のコード join) ...)

sel 命令はスタックトップの値が真であれば then 節のコードを、そうでなければ else 節のコードを実行します。join は then 節、else 節のコードからもとのコードに戻るための命令です。この命令により if 文の次のコードを実行することができます。

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

リスト : if 文のコンパイル

(define (compile-if env)
  (let ((test-form (expression env))
        (then-form #f)
        (else-form #f))
    (unless (eq? *token* 'then)
      (compile-error "if: then expected"))
    (get-token)
    (set! then-form (append (compile-statement env) (list 'join)))
    (get-token)  ; end, semic を読み飛ばす
    (if (eq? *token* 'else)
        (begin (get-token)
               (set! else-form
                     (append (begin0 (compile-statement env)
                                     (get-token)) ; end, semic を読み飛ばす
                             (list 'join))))
      (set! else-form (list 'ldc 0 'join)))
    (unless (eq? *token* 'end)
      (compile-error "if: end expected"))
    (append test-form (list 'sel then-form else-form))))

最初に条件式を expression でコンパイルし、コードを test-form にセットします。それから *token* が then であることを確認します。そうでなければエラーを送出します。次に、then 節を compile-statement でコンパイルし、そのコードの終わりに命令 join を追加します。

compile-statement を実行したあと、*token* は end もしくはセミコロン (semic) になります。get-token で次のトークンを取り出し、else 節がある場合はそれを compile-statement でコンパイルします。else 節がない場合は 0 をスタックに積む命令 ldc 0 join になります。これで 0 を返すことができます。最後に *token* が end であることを確認したら、append で if 文のコードを組み立てて返します。

●block 文のコンパイル

次は block 文をコンパイルする関数 compile-block を作ります。

リスト : block 文のコンパイル

(define (compile-block env)
  (let loop ((code '()))
    (let ((code1 (compile-statement env)))
      (get-token)  ; 実行文の終端 (semic, end) を読み飛ばす
      (cond ((eq? *token* 'end)
             (append code code1))
            (else
             (loop (append code code1 (list 'pop))))))))

compile-statement で実行文をコンパイルし、そのコードを code1 にセットします。そして、get-token で実行文の終端 (end, semic) を読み飛ばして次のトークンを取り出します。*token* が end の場合は block 文の終わりです。append で code と code1 を連結して返します。そうでなければ、code に code1 と命令 pop を追加して、次の実行文をコンパイルします。pop はスタックトップの値を取り除く命令です。

●while 文のコンパイル

次は while 文をコンパイルする関数 compile-while を作ります。

リスト : while 文のコンパイル

(define (compile-while env)
  (let ((test (expression env))
        (body #f))
    (unless (eq? *token* 'do)
      (compile-error "while: do expected"))
    (get-token)
    (set! body (append (compile-block env) (list 'rpt)))
    (append (list 'bgn) test (list 'whl body))))

最初に条件式を expression でコンパイルして、そのコードを test にセットします。次に、*token* が do であることを確認したら、compile-block で while 文の本体をコンパイルして body にセットします。このとき、コードの終わりに命令 rpt を追加します。最後に、while 文のコードを append で組み立てて返します。

●let 文のコンパイル

次は let 文をコンパイルする関数 compile-let を作ります。

リスト : let 文のコンパイル

(define (compile-let env)
  (let loop ((vars '()) (code '()))
    (cond ((eq? *token* 'in)
           (get-token)
           ;; 本体コードの生成
           (append code
                   (list 'args
                         (length vars)
                         'ldf
                         (append (compile-block (cons (reverse vars) env))
                                 (list 'rtn))
                         'app)))
          ((eq? *token* 'ident)
           (let ((var *value*))
             (get-token)
             (unless (eq? *token* '=)
               (compile-error "let: invalid assignment form"))
             (get-token)
             (loop (cons var vars) (append code (expr1 env)))))
          ((eq? *token* 'comma)
           (get-token)
           (loop vars code))
          (else
           (compile-error "let: unexpected token")))))

let 文は匿名関数の呼び出しにコンパイルするのでちょっと複雑です。基本的な考え方は Scheme の let を lambda 式で実現する方法と同じです。変数 vars に左辺値 (局所変数) を、code に右辺値をコンパイルしたコードを格納します。*token* が in の場合は、let の本体を compile-block でコンパイルして、let 文のコードを append で組み立てて出力します。

まず最初に code を実行します。その結果はスタックに格納されています。それを args 命令で取り出して、リストに格納してスタックに追加します。次に、ldf 命令でクロージャを生成し、app 命令でそれを呼び出します。クロージャの本体は compile-block でコンパイルしたコードです。このとき、局所変数の環境に (reverse vars) を追加することを忘れないでください。これで、let 文で定義した変数を局所変数としてコンパイルすることができます。

*token* が ident の場合は局所変数の処理を行います。変数名 *value* を var にセットし、次のトークンが = であることを確認します。そして、var を vars に追加し、左辺の式を expr1 でコンパイルして、そのコードを code に追加します。

もしも expression でコンパイルすると、a = b = 10 のような多重代入が可能になります。しかし、let 文でこれを行うと、a は let 文の局所変数として扱われますが、b は let 文の局所変数ではなく大域変数、または他の文で定義された局所変数としてコンパイルされます。これを避けるため、expression ではなく expr1 でコンパイルしています。

*token* が comma の場合はそれを読み飛ばします。それ以外のトークンはエラーを送出します。あとのプログラムは特に難しいところはないので説明は割愛します。詳細は プログラムリスト をお読みください。

●簡単なテスト

それではここでコンパイラの簡単なテストを行ってみましょう。

Calc> 1 + 2;
=> (ldc 1 ldc 2 + halt)
Calc> 1 + 2 * 3 - 4;
=> (ldc 1 ldc 2 ldc 3 * + ldc 4 - halt)
Calc> (1 + 2) * (3 - 4);
=> (ldc 1 ldc 2 + ldc 3 ldc 4 - * halt)
Calc> begin 1; 2; 3; end
=> (ldc 1 pop ldc 2 pop ldc 3 halt)
Calc> if 1 < 2 then 3; else 4; end
=> (ldc 1 ldc 2 < sel (ldc 3 join) (ldc 4 join) halt)
Calc> if 1 < 2 then 3; end
=> (ldc 1 ldc 2 < sel (ldc 3 join) (ldc 0 join) halt)

式文、if 文、begin 文は正しくコンパイルされています。次は let 文と while 文を試してみましょう。

Calc> let a = 0 in a + 10; end
=> (ldc 0 args 1 ldf (ld (0 . 0) ldc 10 + rtn) app halt)
Calc> let a = 1, b = 2 in a + b; end
=> (ldc 1 ldc 2 args 2 ldf (ld (0 . 0) ld (0 . 1) + rtn) app halt)
Calc> let a = 0, b = 0 in while a < 10 do b = b + a; a = a + 1; end end
=> (ldc 0 ldc 0 args 2 ldf (bgn ld (0 . 0) ldc 10 < whl (ld (0 . 1) ld (0 . 0) +
 lset (0 . 1) pop ld (0 . 0) ldc 1 + lset (0 . 0) rpt) rtn) app halt)
Calc> begin a = b = 0; while a < 10 do b = b + a; a = a + 1; end end
=> (ldc 0 gset (b . 0) gset (a . 0) pop bgn ldg (a . 0) ldc 10 < whl (ldg (b . 0)
 ldg (a . 0) + gset (b . 0) pop ldg (a . 0) ldc 1 + gset (a . 0) rpt) halt)

let 文はクロージャの呼び出しに正しくコンパイルされています。局所変数が環境の位置に変換されていることがわかります。大域変数を使うと、ldg や gset にコンパイルされて、変数と値を格納するペアがコードに埋め込まれています。gset はこのペアの CDR 部の値を書き換えることになります。

次は関数定義を試してみましょう。

Calc> def add(x, y) x + y; end
=> (ldf (ld (0 . 0) ld (0 . 1) + rtn) gset (add . 0) halt)
Calc> def fact(n) if n == 0 then 1; else n * fact(n - 1); end end
=> (ldf (ld (0 . 0) ldc 0 == sel (ldc 1 join) (ld (0 . 0) ld (0 . 0) ldc 1 - arg
s 1 ldg (fact . 0) app * join) rtn) gset (fact . 0) halt)

正しくコンパイルされていますね。最後に匿名関数を試してみましょう。

Calc> fn(x) x * x; end;
=> (ldf (ld (0 . 0) ld (0 . 0) * rtn) halt)
Calc> fn(x) x * x; end (10);
=> (ldc 10 args 1 ldf (ld (0 . 0) ld (0 . 0) * rtn) app halt)
Calc> let a = fn(x) x * x; end in a(10); end
=> (ldf (ld (0 . 0) ld (0 . 0) * rtn) args 1 ldf (ldc 10 args 1 ld (0 . 0) app rtn) app halt)

匿名関数はクロージャを生成する命令に正しくコンパイルされています。また、局所変数と匿名関数を使って局所関数を定義することも簡単にできます。

今回はここまでです。次回は SECD マシンを作成して、実際にプログラムを動かしてみましょう。


●プログラムリスト

;;;
;;; fncalc0.scm : 関数型電卓プログラム (R7RS-small 対応版)
;;;
;;;               コンパイラだけのバージョン
;;;
;;;               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 *line*  #f)
(define *col*   #f)

;;;
;;; グローバルな環境
;;;
(define *global-environment*
  `((exp   primitive ,exp)
    (log   primitive ,log)
    (sin   primitive ,sin)
    (cos   primitive ,cos)
    (tan   primitive ,tan)
    (asin  primitive ,asin)
    (acos  primitive ,acos)
    (atan  primitive ,atan)
    (sqrt  primitive ,sqrt)
    (expt  primitive ,expt)
    (print primitive ,(lambda (x) (display x) (newline) x))))

;;; 大域変数を求める
(define (get-gvar sym)
  (let ((val (assoc sym *global-environment*)))
    (unless val
      (set! val (cons sym 0))
      (push! *global-environment* val))
    val))

;;;
;;; 入力処理
;;;

;;; 文字の読み込み
(define (nextch)
  (set! *ch* (read-char *input*))
  (cond ((eof-object? *ch*)
         (set! *ch* #\null))
        ((eqv? *ch* #\newline)
         (set! *line* (+ *line* 1))
         (set! *col* 0))
        (else
         (set! *col* (+ *col* 1)))))

;;; コンパイルエラー
(define (compile-error mes)
  (error mes *token* *line* *col*))

;;; 先読み記号の取得
(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 (and (not (char-alphabetic? (getch)))
             (not (char-numeric? (getch)))
             (not (eqv? (getch) #\_)))
        (string->symbol (list->string (reverse a)))
      (loop (begin0 (cons (getch) a) (nextch))))))

;;; 文字列
(define (escape-code c)
  (case c
    ((#\t) #\tab)
    ((#\n) #\newline)
    (else c)))

(define (get-string)
  (nextch)
  (let loop ((buff '()))
    (cond ((eqv? (getch) #\")
           (nextch)
           (list->string (reverse buff)))
          ((eqv? (getch) #\\)
           ;; エスケープ記号
           (nextch)
           (loop (begin0 (cons (escape-code (getch)) buff) (nextch))))
          (else
           (loop (begin0 (cons (getch) buff) (nextch)))))))

;; トークンの切り出し
(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 and or not while do begin let in fn eq)
            (set! *token* *value*))
           (else
            (set! *token* 'ident))))
        (else
         (case (getch)
          ((#\#)
           ;; コメントの読み飛ばし
           (do ()
               ((eqv? (getch) #\newline))
             (nextch))
           (get-token))
          ((#\")
           ;; 文字列
           (set! *token* 'string)
           (set! *value* (get-string)))
          ((#\=)
           (set! *token* '=)
           (nextch)
           (when (eqv? (getch) #\=)
             (set! *token* '==)
             (nextch)))
          ((#\+)
           (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))))))

;;;
;;; 式の評価
;;;
(define (expression env)
  (let ((val (expr1 env)))
    (case *token*
      ((=)
       (get-token)
       (case (car val)
         ((ld)
          ;; 局所変数の代入
          (append (expression env) (list 'lset (cadr val))))
         ((ldg)
          ;; 大域変数の代入
          (append (expression env) (list 'gset (cadr val))))
         (else
          (compile-error "invalid assignment form"))))
      (else val))))

;;; 論理演算子 (and と or の優先順位は同じとする)
(define (expr1 env)
  (let loop ((val1 (expr2 env)))
    (case *token*
      ((and)
       (get-token)
       (loop (append val1 (expr2 env) (list 'and))))
      ((or)
       (get-token)
       (loop (append val1 (expr2 env) (list 'or))))
      (else val1))))

;;; 比較演算子 (==, !=, <, <=, >, >= の優先順位は同じとする)
(define (expr2 env)
  (let ((val1 (expr3 env)))
    (case *token*
      ((==)
       (get-token)
       (append val1 (expr3 env) (list '==)))
      ((!=)
       (get-token)
       (append val1 (expr3 env) (list '!=)))
      ((<)
       (get-token)
       (append val1 (expr3 env) (list '<)))
      ((<=)
       (get-token)
       (append val1 (expr3 env) (list '<=)))
      ((>)
       (get-token)
       (append val1 (expr3 env) (list '>)))
      ((>=)
       (get-token)
       (append val1 (expr3 env) (list '>=)))
      ((eq)
       (get-token)
       (append val1 (expr3 env) (list 'eq)))
      (else val1))))

(define (expr3 env)
  (let loop ((val (term env)))
    (case *token*
      ((+)
       (get-token)
       (loop (append val (term env) (list '+))))
      ((-)
       (get-token)
       (loop (append val (term env) (list '-))))
      (else val))))

;;; 項
(define (term env)
  (let loop ((val (factor env)))
    (case *token*
      ((*)
       (get-token)
       (loop (append val (factor env) (list '*))))
      ((/)
       (get-token)
       (loop (append val (factor env) (list '/))))
      ((%)
       (get-token)
       (loop (append val (factor env) (list '%))))
      (else val))))

;;; 実引数のコンパイル
(define (compile-argument env)
  (get-token)
  (if (eq? *token* 'rpar)
      (begin (get-token) (list 'args 0))
    (let loop ((n 1) (a '()))
      (let ((expr (expression env)))
        (case *token*
          ((rpar)
           (get-token)
           (append (append a expr) (list 'args n)))
          ((comma)
           (get-token)
           (loop (+ n 1) (append a expr)))
          (else
           (compile-error "unexpected token")))))))

;;; 仮引数の取得
(define (get-parameter)
  (get-token)
  (unless (eq? *token* 'lpar)
    (compile-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
         (compile-error "unexpected token"))))))

;;; 位置を求める
(define (position var ls)
  (let loop ((i 0) (ls ls))
    (cond ((null? ls) #f)
          ((eqv? var (car ls)) i)
          (else
           (loop (+ i 1) (cdr ls))))))

;;; フレームと局所変数の位置を求める
(define (location var ls)
  (let loop ((i 0) (ls ls))
    (if (null? ls)
        #f
      (let ((j (position var (car ls))))
        (if j
            (cons i j)
          (loop (+ i 1) (cdr ls)))))))

;;; 因子
(define (factor env)
  (case *token*
    ((lpar)
     (get-token)
     (begin0
      (expression env)
      (if (eq? *token* 'rpar)
          (get-token)
          (compile-error "')' expected"))))
    ((number)
     (begin0 (list 'ldc *value*) (get-token)))
    ((string)
     (begin0 (list 'ldc *value*) (get-token)))
    ((not)
     (get-token)
     (append (factor env) (list 'not)))
    ((+)
     ;; 単項演算子 (+ をはずすだけ)
     (get-token)
     (factor env))
    ((-)
     ;; 単項演算子
     (get-token)
     (append (factor env) (list 'neg)))
    ((fn)
     ;; クロージャの生成
     (let ((code (list 'ldf
                       (append (compile-block (cons (get-parameter) env))
                               (list 'rtn)))))
       (get-token)
       (if (eq? *token* 'lpar)
           ;; 関数呼び出し
           (append (compile-argument env) code (list 'app))
         code)))
    ((ident)
     (let ((code #f)
           (pos (location *value* env)))
       (if pos
           ;; 局所変数
           (set! code (list 'ld pos))
         ;; 大域変数
         (set! code (list 'ldg (get-gvar *value*))))
       (get-token)
       (if (eq? *token* 'lpar)
           ;; 関数呼び出し
           (append (compile-argument env) code (list 'app))
         ;; 変数
         code)))
    (else
     (compile-error "unexpected token"))))

;;; if 文のコンパイル
(define (compile-if env)
  (let ((test-form (expression env))
        (then-form #f)
        (else-form #f))
    (unless (eq? *token* 'then)
      (compile-error "if: then expected"))
    (get-token)
    (set! then-form (append (compile-statement env) (list 'join)))
    (get-token)  ; end, semic を読み飛ばす
    (if (eq? *token* 'else)
        (begin (get-token)
               (set! else-form
                     (append (begin0 (compile-statement env)
                                     (get-token)) ; end, semic を読み飛ばす
                             (list 'join))))
      (set! else-form (list 'ldc 0 'join)))
    (unless (eq? *token* 'end)
      (compile-error "if: end expected"))
    (append test-form (list 'sel then-form else-form))))

;;; while 文のコンパイル
(define (compile-while env)
  (let ((test (expression env))
        (body #f))
    (unless (eq? *token* 'do)
      (compile-error "while: do expected"))
    (get-token)
    (set! body (append (compile-block env) (list 'rpt)))
    (append (list 'bgn) test (list 'whl body))))

;;; block 文のコンパイル
(define (compile-block env)
  (let loop ((code '()))
    (let ((code1 (compile-statement env)))
      (get-token)  ; 実行文の終端 (semic, end) を読み飛ばす
      (cond ((eq? *token* 'end)
             (append code code1))
            (else
             (loop (append code code1 (list 'pop))))))))

;;; let 文のコンパイル
(define (compile-let env)
  (let loop ((vars '()) (code '()))
    (cond ((eq? *token* 'in)
           (get-token)
           ;; 本体コードの生成
           (append code
                   (list 'args
                         (length vars)
                         'ldf
                         (append (compile-block (cons (reverse vars) env))
                                 (list 'rtn))
                         'app)))
          ((eq? *token* 'ident)
           (let ((var *value*))
             (get-token)
             (unless (eq? *token* '=)
               (compile-error "let: invalid assignment form"))
             (get-token)
             (loop (cons var vars) (append code (expr1 env)))))
          ((eq? *token* 'comma)
           (get-token)
           (loop vars code))
          (else
           (compile-error "let: unexpected token")))))

;;; 実行文のコンパイル
(define (compile-statement env)
  (case *token*
    ((begin)
     (get-token)
     (compile-block env))
    ((if)
     (get-token)
     (compile-if env))
    ((while)
     (get-token)
     (compile-while env))
    ((let)
     (get-token)
     (compile-let env))
    (else
     ;; 式文
     (begin0
       (expression env)
       (unless (eq? *token* 'semic)
         (compile-error "';' expected"))))))

;;; コンパイル
(define (compile)
  (cond ((eq? *token* 'def)
         ;; 関数定義
         (get-token)
         (unless (eq? *token* 'ident)
           (compile-error "invalid def form"))
         (let ((name *value*)
               (code (append (compile-block (list (get-parameter)))
                             (list 'rtn))))
           (list 'ldf code 'gset (get-gvar name))))
        (else
         (compile-statement '()))))

;;; 入力をクリアする
(define (clear-input-data)
  (do ()
      ((eqv? *ch* #\newline))
    (nextch)))

;;; プロンプトの表示
(define (prompt)
  (display "Calc> ")
  (flush-output-port)
  (set! *line* 0)
  (set! *col* 0))

(define (calc)
  (prompt)
  (nextch)
  (call/cc
    (lambda (break)
      (let loop ()
        (guard (err
                (else (display "ERROR: ")
                      (display (error-object-message err))
                      (unless
                       (null? (error-object-irritants err))
                       (display (error-object-irritants err)))
                      (newline)
                      (clear-input-data)))
          (get-token)
          (when (eqv? *token* 'eof) (break #t))
          (let ((code (append (compile) (list 'halt))))
            (display "=> ")
            (display code)
            (newline)))
        (prompt)
        (loop)))))

;;; 実行
(calc)

初版 2011 年 8 月 14 日
改訂 2021 年 6 月 19 日

Copyright (C) 2011-2021 Makoto Hiroi
All rights reserved.

[ PrevPage | Scheme | NextPage ]