Common Lisp風のLISPを作ってみる（１１．変数）

Common Lispで変数といえば、defvarにlet、setqですね。これらは組み込み関数ではなく、スペシャルオペレーターと呼ばれるものです。組み込み関数は引数の値だけが必要でしたが、スペシャルオペレーターは引数の式（評価前の！）と環境が必要です。評価器を少し直します。そして、letとlet*についてですが、SICPでは大きな違いだったと思います。ですがCによる実装ではほとんど変わりがありません。そのあたりにご注目いただければと思います。
ソースコード

eval.c

eval_list関数はスペシャルオペレーターのために３行追加されています。

eval.c

static void *eval_list(void *obj, void *env_func, void *env_var) {

(中略)

    if (environment_get_recurse(env_func, symbol, &obj2)) {
        HEADER *h = (HEADER *)obj2;
        if (h->type == TYPE_BUILT_IN_FUNC) {
            BUILT_IN_FUNC *f = (BUILT_IN_FUNC *)obj2;
            void *args = cdr(obj);
            void *p = args;
            while (p != NIL) {
                void *retval = eval(car(p), env_func, env_var);
                if (!retval) return 0;
                rplaca(p, retval);
                p = cdr(p);
            }
            return f->f(args);
        } else if (h->type == TYPE_SPECIAL_OPERATOR) {
            SPECIAL_OPERATOR *op = (SPECIAL_OPERATOR *)obj2;
            return op->op(cdr(obj), env_func, env_var);
        } else {
            fprintf(stderr, "未実装のコードに到達しました\n");
            state = STATE_ERROR;
            return 0;
        }
    } else {
        fprintf(stderr, "%sという名前の関数がありません\n", sym);
        state = STATE_ERROR;
        return 0;
    }
}

register_special_operator関数はグローバル環境にスペシャルオペレーターを登録します。

eval.c

static void register_special_operator(char *name,
                                      void *(* op)(void *, void *, void *)) {
    SPECIAL_OPERATOR *op2 = (SPECIAL_OPERATOR *)malloc(sizeof(SPECIAL_OPERATOR));
    op2->h.type = TYPE_SPECIAL_OPERATOR;
    op2->op = op;
    environment_add(env_func_global, make_symbol(name), op2);
}

今回は例の4つが登録されています。

eval.c

    register_special_operator("DEFVAR", &op_defvar);
    register_special_operator("SETQ", &op_setq);
    register_special_operator("LET", &op_let);
    register_special_operator("LET*", &op_let_star);

built_in_func.c

op_defvar関数はスペシャルオペレーターdefvarの実体です。defvarの特殊な挙動についてなのですが、同じ変数を2回defvarするとエラーは発生しないが変数の値は更新されない、というのがあります。Common Lispでもそうなるので試してみてください。

built_in_func.c

void *op_defvar(void *args, void *env_func, void *env_var) {
    void *val;
    if (list_length(args) != 2) {
        fprintf(stderr, "DEFVAR: 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!symbolp(car(args))) {
        fprintf(stderr, "DEFVAR: 引数1がシンボル型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    val = eval(car(cdr(args)), env_func, env_var);
    if (!val) return 0;
    if (!environment_exists(env_var_global, car(args))) {
        environment_add(env_var_global, car(args), val);
    }
    return car(args);
}

op_setq関数はスペシャルオペレーターsetqの実体です。setqはちゃんと変数がないとエラーが発生するようになっています。
（と思ったらSBCLではワーニングだしCLISPではワーニングさえもなかった...。defvarとは...）

built_in_func.c

void *op_setq(void *args, void *env_func, void *env_var) {
    void *val;
    if (list_length(args) != 2) {
        fprintf(stderr, "SETQ: 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!symbolp(car(args))) {
        fprintf(stderr, "SETQ: 引数1がシンボル型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    val = eval(car(cdr(args)), env_func, env_var);
    if (!val) return 0;
    if (!environment_exists_recurse(env_var, car(args))) {
        fprintf(stderr, "SETQ: %sという名前の変数はありません\n",
                        get_symbol_string(car(args)));
        state = STATE_ERROR;
        return 0;
    }
    environment_modify_recurse(env_var, car(args), val);
    return val;
}

op_let関数はスペシャルオペレーターletの実体です。やたら長いのですが、実はletが取るフォームが3通りあるからです。そしてletとlet*の違いですが、中ほどにあるevalの呼び出しにenv_varを入れるかnew_env_varを入れるかだけです。letとlet*のコストは本当に変わらないのです！

built_in_func.c

void *op_let(void *args, void *env_func, void *env_var) {
    void *new_env_var = environment_init(env_var);
    void *var_exp_list = car(args);
    if (!listp(var_exp_list)) {
        fprintf(stderr, "LET: 引数1がリストではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    while (var_exp_list != NIL) {
        void *var_exp = car(var_exp_list);
        if (symbolp(var_exp)) {
            environment_add(new_env_var, var_exp, NIL);
        } else if (listp(var_exp)) {
            size_t len = list_length(var_exp);
            if (len == 1) {
                if (!symbolp(car(var_exp))) {
                    fprintf(stderr, "LET: 引数1が不正な形式です\n");
                    state = STATE_ERROR;
                    return 0;
                }
                environment_add(new_env_var, car(var_exp), NIL);
            } else if (len == 2) {
                void *val;
                if (!symbolp(car(var_exp))) {
                    fprintf(stderr, "LET: 引数1が不正な形式です\n");
                    state = STATE_ERROR;
                    return 0;
                }
                val = eval(car(cdr(var_exp)), env_func, env_var);
                if (!val) return 0;
                environment_add(new_env_var, car(var_exp), val);
            } else {
                fprintf(stderr, "LET: 引数1が不正な形式です\n");
                state = STATE_ERROR;
                return 0;
            }
        } else {
            fprintf(stderr, "LET: 引数1が不正な形式です\n");
            state = STATE_ERROR;
            return 0;
        }
        var_exp_list = cdr(var_exp_list);
    }
    {
        void *p = cdr(args);
        void *retval = NIL;
        while (p != NIL) {
            retval = eval(car(p), env_func, new_env_var);
            if (!retval) return 0;
            p = cdr(p);
        }
        return retval;
    }
}

動かしてみよう

変数に自由に値を代入できるというのは楽しいものです。

> (defvar *a* 1)
*A*
> (defvar *b* 2)
*B*
> (+ *a* *b*)
3
> (let (a) a)
NIL
> (let ((a)) a)
NIL
> (let ((a 3)) a)
3
> (let ((i 1) (j i)) j) 
Iという名前の変数がありません
> (let* ((i 1) (j i)) j)
1
> (setq *a* 10)
10
> *a*
10
> (let ((a 5)) (setq a 6) a)
6