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

今回は関数の定義についてやっていきます。`defun`と`flet`, `labels`ですね。
[ソースコード](https://github.com/haruo-wakakusa/my-lisp2/tree/main/chapter14)
# eval.c
`eval_list`関数の中で`eval_user_defined_func`関数を呼び出しています。
```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) {
        
        (中略)
        
        } else if (h->type == TYPE_USER_DEFINED_FUNC) {
            return eval_user_defined_func(
                symbol, obj2, cdr(obj), env_func, env_var);
        } 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;
    }
}
```
ユーザー定義関数の評価は主に`eval_user_defined_func`関数の中で行なっています。それにしても長い...
```eval.c
static void *eval_user_defined_func(
        void *name, void *func, void *args, void *env_func, void *env_var) {
    USER_DEFINED_FUNC *f = (void *)func;
    void *arglist = car(f->body);
    int has_rest_param = find_symbol("&REST", arglist);
    CONS_BUFFER cbuf;
    void *p;
    void *new_env_var;
    void *retval = NIL;
    if (has_rest_param) {
        if (list_length(args) < list_length(arglist) - 2) {
            fprintf(stderr, "FUNCTION \"%s\": 引数の数が一致しません\n",
                            get_symbol_string(name));
            state = STATE_ERROR;
            return 0;
        }
    } else {
        if (list_length(args) != list_length(arglist)) {
            fprintf(stderr, "FUNCTION \"%s\": 引数の数が一致しません\n",
                            get_symbol_string(name));
            state = STATE_ERROR;
            return 0;
        }
    }
    cbuf = cons_buffer_allocate();
    p = args;
    while (p != NIL) {
        retval = eval(car(p), env_func, env_var);
        if (!retval) {
            cons_buffer_free(cbuf);
            return 0;
        }
        cons_buffer_add(cbuf, retval);
        p = cdr(p);
    }
    args = cons_buffer_get_list(cbuf);
    cons_buffer_free(cbuf);
    new_env_var = environment_init(f->env_var);
    if (has_rest_param) {
        while (strcmp("&REST", get_symbol_string(car(arglist))) != 0) {
            environment_add(new_env_var, car(arglist), car(args));
            args = cdr(args);
            arglist = cdr(arglist);
        }
        environment_add(new_env_var, car(cdr(arglist)), args);
    } else {
        while (arglist != NIL) {
            environment_add(new_env_var, car(arglist), car(args));
            args = cdr(args);
            arglist = cdr(arglist);
        }
    }
    retval = NIL;
    for (p = cdr(f->body); p != NIL; p = cdr(p)) {
        retval = eval(car(p), f->env_func, new_env_var);
        if (!retval) return 0;
    }
    return retval;
}
```
# built_in_func.c
`op_defun`関数はスペシャルオペレーター`defun`の実体です。Common Lispでは関数の仮引数のリストのことをラムダリスト(lambda list)と呼びますが、Common Lispではオプション引数やキーワード引数などを設定できるので、それらを真面目に実装するとコード行数が長く、可読性の悪いコードになってしまいます。なので`&REST`以外のラムダリストキーワードをエラーにしています(なので長いというのもありますが...)。
```built_in_func.c
void *op_defun(void *args, void *env_func, void *env_var) {
    void *name = car(args);
    void *arglist = car(cdr(args));
    void *p;
    USER_DEFINED_FUNC *f;
    if (!symbolp(name)) {
        fprintf(stderr, "関数名がシンボルではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!listp(arglist)
            || !all_symbol_p(arglist)
            || !unique_symbol_list_p(arglist)) {
        fprintf(stderr, "引数リストが不正な形式です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (find_symbol("&OPTIONAL", arglist)) {
        fprintf(stderr, "オプション引数は非対応です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (find_symbol("&KEY", arglist)) {
        fprintf(stderr, "キーワード引数は非対応です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (find_symbol("&AUX", arglist)) {
        fprintf(stderr, "&AUXの指定は非対応です\n");
        state = STATE_ERROR;
        return 0;
    }
    if (find_symbol("&ALLOW-OTHER-KEYS", arglist)) {
        fprintf(stderr, "&ALLOW-OTHER-KEYSの指定は非対応です\n");
        state = STATE_ERROR;
        return 0;
    }
    p = arglist;
    while (p != NIL && strcmp("&REST", get_symbol_string(car(p))) != 0)
        p = cdr(p);
    if (p != NIL && list_length(p) != 2) {
        fprintf(stderr, "&RESTが不正な場所にあります\n");
        state = STATE_ERROR;
        return 0;
    }
    f = (USER_DEFINED_FUNC *)malloc(sizeof(USER_DEFINED_FUNC));
    f->h.type = TYPE_USER_DEFINED_FUNC;
    f->body = cdr(args);
    f->env_func = env_func;
    f->env_var = env_var;
    if (environment_exists(env_func_global, name)) {
        environment_modify(env_func_global, name, f);
    } else {
        environment_add(env_func_global, name, f);
    }
    return name;
}
```
ふと思い出したように`progn`を定義しています。
```built_in_func.c
void *op_progn(void *args, void *env_func, void *env_var) {
    void *retval = NIL;
    for ( ; args != NIL; args = cdr(args)) {
        retval = eval(car(args), env_func, env_var);
        if (!retval) return 0;
    }
    return retval;
}
```
`op_flet`関数はスペシャルオペレーター`flet`の実体です。それにしても長いですね。エラーをはじくのに行数を使っている感じです。`flet`と`labels`の違いは、関数オブジェクトに入れている環境が`env_func`か`new_env_func`かの違いになります。
```built_in_func.c
void *op_flet(void *args, void *env_func, void *env_var) {
    void *funclist = car(args);
    void *new_env_func = environment_init(env_func);
    void *retval = NIL;
    if (args == NIL) {
        fprintf(stderr, "FLET: 引数が少なすぎます\n");
        state = STATE_ERROR;
        return 0;
    }
    if (!listp(funclist)) {
        fprintf(stderr, "FLET: 関数リストがリストではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    while (funclist != NIL) {
        void *func = car(funclist);
        void *name;
        void *arglist;
        void *p;
        USER_DEFINED_FUNC *f;
        if (!listp(func) || list_length(func) < 2) {
            fprintf(stderr, "FLET: 関数リスト内の記述が不正です\n");
            state = STATE_ERROR;
            return 0;
        }
        name = car(func);
        arglist = car(cdr(func));
        if (!symbolp(name)
                || !listp(arglist)
                || !all_symbol_p(arglist)
                || !unique_symbol_list_p(arglist)
                || find_symbol("&OPTIONAL", arglist)
                || find_symbol("&KEY", arglist)
                || find_symbol("&AUX", arglist)
                || find_symbol("&ALLOW-OTHER-KEYS", arglist)) {
            fprintf(stderr, "FLET: 関数リスト内の記述が不正です\n");
            state = STATE_ERROR;
            return 0;
        }
        p = arglist;
        while (p != NIL && strcmp("&REST", get_symbol_string(car(p))) != 0)
            p = cdr(p);
        if (p != NIL && list_length(p) != 2) {
            fprintf(stderr, "FLET: 関数リスト内の記述が不正です\n");
            state = STATE_ERROR;
            return 0;
        }
        f = (USER_DEFINED_FUNC *)malloc(sizeof(USER_DEFINED_FUNC));
        f->h.type = TYPE_USER_DEFINED_FUNC;
        f->body = cdr(func);
        f->env_func = env_func;
        f->env_var = env_var;
        if (!environment_exists(new_env_func, name)) {
            environment_add(new_env_func, name, f);
        } else {
            fprintf(stderr, "FLET: 関数リスト内の記述が不正です\n");
            state = STATE_ERROR;
            return 0;
        }
        funclist = cdr(funclist);
    }
    for (args = cdr(args); args != NIL; args = cdr(args)) {
        retval = eval(car(args), new_env_func, env_var);
        if (!retval) return 0;
    }
    return retval;
}
```
# helper.c
上記関数を書くために用意したヘルパー関数です。
```helper.c
int all_symbol_p(void *list1) {
    for ( ; list1 != NIL; list1 = cdr(list1)) {
        if (!symbolp(car(list1))) return 0;
    }
    return 1;
}
    
int symbol_equal(void *symbol1, void *symbol2) {
    return strcmp(get_symbol_string(symbol1),
                  get_symbol_string(symbol2)) == 0;
}   

int unique_symbol_list_p(void *obj) {
    void *p;
    void *q;
    for (p = obj; p != NIL; p = cdr(p)) {
        for (q = cdr(p); q != NIL; q = cdr(q)) {
            if (symbol_equal(car(p), car(q))) return 0;
        }
    }
    return 1;
}
    
int find_symbol(char *name, void *list1) {
    while (list1 != NIL) {
        if (strcmp(name, get_symbol_string(car(list1))) == 0) return 1;
        list1 = cdr(list1);
    }
    return 0;
}
```
# 動かしてみよう
まずは`defun`から。
```
> (defun 1+ (x) (+ x 1))
1+
> (1+ 3)
4
> (defun first (x) (car x))
FIRST
> (first (list 1 2 3))
1
```
`flet`はちょっと例を出しづらいのですが...
```
> (flet ((f (x) (* x 2))) (f 3))
6
```
さて、`labels`です。`labels`は`flet`とは異なり再帰させることができます。なので、こんな感じになります。
```
> (labels ((f (x) (if (= x 0) 0 (+ x (f (- x 1)))))) (f 10))
55
> (flet ((f (x) (if (= x 0) 0 (+ x (f (- x 1)))))) (f 10))
Fという名前の関数がありません
```