Go to Qiita Advent Calendar 2024 Top
LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@HaruoWakakusa

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

Posted at

今回は関数の定義についてやっていきます。defunとflet, labelsですね。
ソースコード

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という名前の関数がありません
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?