Common Lisp風のLISPを作ってみる（１３．ループ）

今回はループです。と言っても、`do`や`loop`のことではありません。`block`と`tagbody`を実装します。`block`と`tagbody`がスペシャルオペレーターで、`do`と`loop`はマクロだからですね。マクロの実装後に`do`は実装しますが、`loop`は仕様が巨大なのでmy-lisp2のシリーズでは取り上げません。
[ソースコード](https://github.com/haruo-wakakusa/my-lisp2/tree/main/chapter13)
# built_in_func.c
`op_block`関数はスペシャルオペレーター`block`の実体です。
```built_in_func.c
void *op_block(void *args, void *env_func, void *env_var) {
    void *name;
    void *body;
    void *retval = NIL;
    if (args == NIL) {
        fprintf(stderr, "BLOCK: 引数が少なすぎます\n");
        state = STATE_ERROR;
        return 0;
    }
    name = car(args);
    body = cdr(args);
    while (body != NIL) {
        retval = eval(car(body), env_func, env_var);
        if (!retval) {
            if (state == STATE_JUMP_RETURN) {
                if (strcmp(get_symbol_string(block_name_when_return),
                           get_symbol_string(name)) == 0) {
                    state = STATE_NORMAL;
                    return return_value_when_return;
                }
            }
            return 0;
        }
        body = cdr(body);
    }
    return retval;
}
```
`op_return_from`関数はスペシャルオペレーター`return-from`の実体です。
```built_in_func.c
void *op_return_from(void *args, void *env_func, void *env_var) {
    void *retval;
    if (args == NIL) {
        fprintf(stderr, "RETURN-FROM: 引数が少なすぎます\n");
        state = STATE_ERROR;
        return 0;
    }
    if (list_length(args) >= 3) {
        fprintf(stderr, "RETURN_FROM: 引数が多すぎます\n");
        state = STATE_ERROR;
        return 0;
    }
    block_name_when_return = car(args);
    retval = eval(car(cdr(args)), env_func, env_var);
    if (!retval) return 0;
    return_value_when_return = retval;
    state = STATE_JUMP_RETURN;
    return 0;
}
```
`op_tagbody`関数はスペシャルオペレーター`tagbody`の実体です。`block`も`tagbody`も触ったことがない人がたいていだと思いますので、後でその使い方を見ていきましょう。
```built_in_func.c
void *op_tagbody(void *args, void *env_func, void *env_var) {
    void *retval;
    void *p = args;
    while (p != NIL) {
    LOOP1:
        if (symbolp(car(p))) {
            p = cdr(p);
            continue;
        }
        retval = eval(car(p), env_func, env_var);
        if (!retval) {
            if (state == STATE_JUMP_GO) {
                p = args;
                while (p != NIL) {
                    if (symbolp(car(p))
                            && strcmp(
                                get_symbol_string(car(p)),
                                get_symbol_string(tag_name_when_go)) == 0) {
                        state = STATE_NORMAL;
                        goto LOOP1;
                    }
                    p = cdr(p);
                }
            }
            return 0;
        }
        p = cdr(p);
    }
    return NIL;
}
```
`op_go`関数はスペシャルオペレーター`go`の実体です。
```built_in_func.c
void *op_go(void *args, void *env_func, void *env_var) {
    if (list_length(args) != 1) {
        fprintf(stderr, "GO: 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!symbolp(car(args))) {
        fprintf(stderr, "GO: 引数がシンボルではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    state = STATE_JUMP_GO;
    tag_name_when_go = car(args);
    return 0;
}
```
`f_prin1`関数は`prin1`関数の実体です。ループをするときにその途中経過を表示したくなったので追加しました。ちなみにグローバル変数`is_printed_in_eval`は、改行数を調整するために付けています。SBCL, CLISPともに不可解な改行処理を行なっていたためです。
```built_in_func.c
void *f_prin1(void *args) {
    if (list_length(args) != 1) {
        fprintf(stderr, "FUNCTION \"PRIN1\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    printer_print(stdout, car(args));
    is_printed_in_eval = 1;
    return car(args);
}
```
`f_print`関数は`print`関数の実体です。`princ`関数はmy-lisp2の中には実装していないです。行数が増えそうなので端折りました。
```built_in_func.c
void *f_print(void *args) {
    if (list_length(args) != 1) {
        fprintf(stderr, "FUNCTION \"PRINT\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    putc('\n', stdout);
    printer_print(stdout, car(args));
    putc(' ', stdout);
    is_printed_in_eval = 1;
    return car(args);
}
```
`f_load`関数は`load`関数の実体です。`test.c`のREPLループを流用しています。ただしプリンターは外してあります。また、REPLループではエラー発生時に処理を継続しますが、`load`関数では処理を停止します。
```built_in_func.c
void *f_load(void *args) {
    STRING *filename;
    FILE *fp;
    void *obj;
    if (list_length(args) != 1) {
        fprintf(stderr, "FUNCTION \"LOAD\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!stringp(car(args))) {
        fprintf(stderr, "FUNCTION \"LOAD\": 引数が文字列ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    filename = (STRING *)car(args);
    fp = fopen(get_string_string(filename), "r");
    if (!fp) return NIL;
    while (1) {
        obj = reader_read(fp);
        if (!obj) {
            if (state == STATE_EXIT) {
                break;
            } else if (state == STATE_ERROR) {
                fclose(fp);
                return 0;
            } else {
                fprintf(stderr, "未実装のコードに到達しました\n");
                fclose(fp);
                return 0;
            }
        }
        fix_to_dotted_list(obj);
        if (!check_single_dot(obj)) {
            fprintf(stderr, "ドットをシンボルとして使用することはできません\n");
            state = STATE_ERROR;
            fclose(fp);
            return 0;
        }
        obj = eval_top(obj);
        if (!obj) {
            if (state == STATE_EXIT) {
                break;
            } else if (state == STATE_ERROR) {
                fclose(fp);
                return 0;
            } else if (state == STATE_JUMP_RETURN || state == STATE_JUMP_GO) {
                fprintf(stderr, "ジャンプに失敗しました\n");
                fclose(fp);
                state = STATE_ERROR;
                return 0;
            } else {
                fprintf(stderr, "未実装のコードに到達しました\n");
                fclose(fp);
                return 0;
            }
        }
    }
    fclose(fp);
    state = STATE_NORMAL;
    return T;
}
```
# printer.h
```printer.h
extern int is_printed_in_eval;
```
# printer.c
```printer.c
int is_printed_in_eval = 0;
```
# test.c
変数`is_printed_in_eval`が実際に何をやっているのかが分かるかと思います。評価中にプリントした時に改行を1個増やしています。
```test.c
int main(void) {

(中略)

        is_printed_in_eval = 0;
        obj = eval_top(obj);
        if (!obj) {

(中略)

        }
        if (is_printed_in_eval) fputc('\n', stdout);
        printer_print(stdout, obj);
        fputc('\n', stdout);
    }
    return 0;
}
```
# 動かしてみよう
まずは`block`からです。`block`には名前を付けることができます。下の例では`a`という名前を付けていますね。`block`は`progn`のように式を1つずつ評価して行きます。ただし`return-from`が呼び出されると`block`を抜けます。この時`block`が返す値は`return-from`が指定した値となります。
```
> (block a (prin1 1) (prin1 2) (prin1 3))
123
3
> (block a (prin1 1) (prin1 2) (return-from a 4) (prin1 3))
12
4
```
次に`tagbody`です。`tagbody`はその内部の任意の場所にタグと呼ばれるシンボルを置くことができます。このタグは評価されません。`tagbody`の中で`go`が呼び出されると、`go`で指定したタグにジャンプします。`tagbody`は必ず`NIL`を返します。
```
> (tagbody (prin1 1) (go a) (prin1 2) a (prin1 3))
13
NIL
```
そこで、`tmp.lisp`というファイルを用意しました。1から9までを表示するプログラムです。
```tmp.lisp
(let ((x 1))
  (tagbody
    a
    (prin1 x)
    (setq x (+ x 1))
    (if (< x 10) (go a))))
```
実行してみます。
```
> (load "tmp.lisp")
123456789
T
```
うまく行ったみたいです。でも折角なので1+2+...+10を計算して返して欲しいですね。なので書いてみました。
```
> 
(let ((i 1) (sum 0))
  (block a 
    (tagbody
      a
      (if (> i 10) (return-from a sum))
      (setq sum (+ sum i))
      (setq i (+ i 1))
      (go a))))
55
```
うまくいったみたいですね。