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

LISPなら高階関数が使えなきゃね！ってことで今回は高階関数です。
[ソースコード](https://github.com/haruo-wakakusa/my-lisp2/tree/main/chapter15)
# built_in_func.c
`op_function`関数はスペシャルオペレーター`function`の実体です。これは`#'`というリードマクロで呼び出すことが多いのですが、なんとここにラムダ形式を書くことができるので、書けるようにしなければなりません。
```built_in_func.c
void *op_function(void *args, void *env_func, void *env_var) {
    void *arg1 = car(args);
    if (list_length(args) != 1) {
        fprintf(stderr, "FUNCTION: 引数の数が1つではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    if (symbolp(arg1)) {
        void *obj;
        if (environment_get_recurse(env_func, arg1, &obj)) {
            HEADER *h = (HEADER *)obj;
            if (h->type == TYPE_BUILT_IN_FUNC
                    || h->type == TYPE_USER_DEFINED_FUNC) {
                return obj;
            } else {
                fprintf(stderr, "FUNCTION: %sは関数ではありません\n",
                                get_symbol_string(arg1));
                state = STATE_ERROR;
                return 0;
            }
        } else {
            fprintf(stderr, "FUNCTION: %sという関数は見つかりませんでした\n",
                            get_symbol_string(arg1));
            state = STATE_ERROR;
            return 0;
        }
    }
    if (listp(arg1)
            && list_length(arg1) >= 2
            && symbolp(car(arg1))
            && strcmp("LAMBDA", get_symbol_string(car(arg1))) == 0) {
        void *arglist = car(cdr(arg1));
        void *p;
        USER_DEFINED_FUNC *f;
        if (!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, "LAMBDA: 引数リストが不正です\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, "LAMBDA: 引数リストが不正です\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(arg1);
        f->env_func = env_func;
        f->env_var = env_var;
        return (void *)f;
    }
    fprintf(stderr, "FUNCTION: 引数が不正です\n");
    state = STATE_ERROR;
    return 0;
}
```
`f_funcall`関数はスペシャルオペレーター`funcall`の実体です。`&REST`キーワードを使えるようにしているから長いのでしょうか...
```built_in_func.c
void *f_funcall(void *args) {
    HEADER *h;
    if (args == NIL) {
        fprintf(stderr, "FUNCTION \"FUNCALL\": 引数が少なすぎます\n");
        state = STATE_ERROR;
        return 0;
    }
    h = (HEADER *)car(args);
    if (h->type == TYPE_BUILT_IN_FUNC) {
        BUILT_IN_FUNC *f = (BUILT_IN_FUNC *)car(args);
        return f->f(cdr(args));
    } else if (h->type == TYPE_USER_DEFINED_FUNC) {
        USER_DEFINED_FUNC *f = (USER_DEFINED_FUNC *)car(args);
        void *arglist = car(f->body);
        int has_rest_param = find_symbol("&REST", arglist);
        void *new_env_var;
        void *p;
        void *retval;
        if (has_rest_param) {
            if (list_length(cdr(args)) < list_length(arglist) - 2) {
                fprintf(stderr, "FUNCTION \"FUNCALL\": 引数の数が一致しません\n");
                state = STATE_ERROR;
                return 0;
            }
        } else {
            if (list_length(cdr(args)) != list_length(arglist)) {
                fprintf(stderr, "FUNCTION \"FUNCALL\": 引数の数が一致しません\n");
                state = STATE_ERROR;
                return 0;
            }
        }
        new_env_var = environment_init(f->env_var);
        args = cdr(args);
        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;
    } else {
        fprintf(stderr, "FUNCTION \"FUNCALL\": 引数1が関数オブジェクトではありません\n");
        state = STATE_ERROR;
        return 0;
    }
}
```
`f_apply`関数はスペシャルオペレーター`apply`の実体です。`funcall`よりも短いのは内部で`funcall`を使ってるからです。
```built_in_func.c
/* applyはspreadable argument list designatorに対応しない */
void *f_apply(void *args) {
    if (list_length(args) != 2) {
        fprintf(stderr, "FUNCTION \"APPLY\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    return f_funcall(cons(car(args), car(cdr(args))));
}
```
忘れたかのように`quote`も定義しています。
```built_in_func.c
void *op_quote(void *args, void *env_func, void *env_var) {
    if (list_length(args) != 1) {
        fprintf(stderr, "QUOTE: 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    return car(args);
}
```
# printer.c
`function`によって関数オブジェクトが扱えるようになったので、プリンターのほうも追記する必要があります。
```printer.c
void printer_print(FILE *stream, void *obj) {
    HEADER *h;

    if (!obj) {
        fprintf(stream, "[!!!NULL POINTER!!!]");
        return;
    }
    h = (HEADER *)obj;
    switch (h->type) {
    case TYPE_SYMBOL:
        print_symbol(stream, obj);
        break;
    case TYPE_CONS:
        print_list(stream, obj);
        break;
    case TYPE_STRING:
        print_string(stream, obj);
        break;
    case TYPE_NUMBER:
        print_number(stream, obj);
        break;
    case TYPE_BUILT_IN_FUNC:
        fprintf(stream, "#<BUILT-IN-FUNCTION>");
        break;
    case TYPE_USER_DEFINED_FUNC:
        fprintf(stream, "#<USER-DEFINED-FUNCTION>");
        break;
    default:
        fprintf(stderr, "未実装のコードに到達しました\n");
    }
}
```
# 動かしてみよう
高階関数`mapcar`と`reduce`をファイルに書いて実行します。
```tmp.lisp
(defun my-reverse (list)
  (let ((rest list) (res nil))
    (block nil
      (tagbody
        a
        (if (null rest) (return-from nil res))
        (setq res (cons (car rest) res))
        (setq rest (cdr rest))
        (go a)))))

(defun my-mapcar (func list)
  (let ((rest list) (res nil))
    (my-reverse
      (block nil
        (tagbody
          a
          (if (null rest) (return-from nil res))
          (setq res (cons (funcall func (car rest)) res))
          (setq rest (cdr rest))
          (go a))))))

(defun my-reduce (func list)
  (let ((rest (cdr list)) (acc (car list)))
    (block nil
      (tagbody
        a
        (if (null rest) (return-from nil acc))
        (setq acc (funcall func acc (car rest)))
        (setq rest (cdr rest))
        (go a)))))
```

```
> (load "tmp.lisp")
T
> (my-mapcar #'(lambda (x) (+ x 1)) '(1 2 3))
(2 3 4)
> (my-reduce #'* '(1 2 3 4 5))
120
```
問題なく動くことが確認できましたね。ちなみに`tmp.lisp`はSBCLでも動作します。`reduce`について言えば、`:from-end`を実装できないのが少し残念ではあります。