今回はループです。と言っても、doやloopのことではありません。blockとtagbodyを実装します。blockとtagbodyがスペシャルオペレーターで、doとloopはマクロだからですね。マクロの実装後にdoは実装しますが、loopは仕様が巨大なのでmy-lisp2のシリーズでは取り上げません。
ソースコード
built_in_func.c
op_block関数はスペシャルオペレーターblockの実体です。
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の実体です。
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も触ったことがない人がたいていだと思いますので、後でその使い方を見ていきましょう。
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の実体です。
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ともに不可解な改行処理を行なっていたためです。
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の中には実装していないです。行数が増えそうなので端折りました。
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関数では処理を停止します。
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
extern int is_printed_in_eval;
printer.c
int is_printed_in_eval = 0;
test.c
変数is_printed_in_evalが実際に何をやっているのかが分かるかと思います。評価中にプリントした時に改行を1個増やしています。
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までを表示するプログラムです。
(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
うまくいったみたいですね。