Common Lisp風のLISPを作ってみる（１０．四則演算、比較）

今回は、評価器を構築し、さらに演算系の関数を実装することで簡易的な電卓を作ります。
[ソースコード](https://github.com/haruo-wakakusa/my-lisp2/tree/main/chapter10)
# eval.h
`env_func_global`, `env_var_global`はそれぞれグローバル関数・グローバル変数の環境です。
```eval.h
/*
 * eval.h
 */

#ifndef EVAL_H_
#define EVAL_H_

extern void *env_func_global;
extern void *env_var_global;

void eval_init(void);
void *eval_top(void *obj);
void *eval(void *obj, void *env_func, void *env_var);

#endif
```
# eval.c
まずはインクルード文、プロトタイプ宣言、グローバル変数の定義です。
```eval.c
/*
 * eval.c
 */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "../chapter02/type.h"
#include "helper.h"
#include "../chapter05/environment.h"
#include "../chapter05/state.h"
#include "built_in_func.h"
#include "eval.h"

static void *eval_list(void *obj, void *env_func, void *env_var);
static void *eval_symbol(void *obj, void *env_func, void *env_var);
static void register_built_in_func(char *name, void *(* func)(void *));

void *env_func_global = 0;
void *env_var_global = 0;
```
`eval_init`は評価器を初期化します（とはいえやっていることのほとんどは組み込み関数の登録ですね...）。
```eval.c
void eval_init(void) {
    env_func_global = environment_init(NIL);
    env_var_global = environment_init(NIL);

    register_built_in_func("+", &f_add);
    register_built_in_func("-", &f_sub);
    register_built_in_func("*", &f_mul);
    register_built_in_func("/", &f_div);
    register_built_in_func("=", &f_number_equal);
    register_built_in_func(">", &f_number_gt);
    register_built_in_func(">=", &f_number_ge);
    register_built_in_func("<", &f_number_lt);
    register_built_in_func("<=", &f_number_le);
    register_built_in_func("REM", &f_rem);
    register_built_in_func("CONS", &f_cons);
    register_built_in_func("LIST", &f_list);
    register_built_in_func("CONSP", &f_consp);
    register_built_in_func("CAR", &f_car);
    register_built_in_func("CDR", &f_cdr);
    register_built_in_func("RPLACA", &f_rplaca);
    register_built_in_func("RPLACD", &f_rplacd);
    register_built_in_func("SYMBOLP", &f_symbolp);
    register_built_in_func("LISTP", &f_listp);
    register_built_in_func("LIST-LENGTH", &f_list_length);
    register_built_in_func("NULL", &f_null);
    register_built_in_func("EXIT", &f_exit);
}
```
`eval_top`関数はフォームを評価します。評価にはグローバル環境を使用します。
```eval.c
void *eval_top(void *obj) {
    return eval(obj, env_func_global, env_var_global);
}
```
`eval`関数はフォームを評価します。評価の時に使う環境も指定します。
```eval.c
void *eval(void *obj, void *env_func, void *env_var) {
    HEADER *h = (HEADER *)obj;
    switch (h->type) {
    case TYPE_CONS:
        return eval_list(obj, env_func, env_var);
    case TYPE_SYMBOL:
        return eval_symbol(obj, env_func, env_var);
    default:
        return obj;
    }
}
```
`eval_list`関数はリストを評価します。ちなみにCommon Lispでは`((lambda (x) (1+ x)) 1)`のようなJavaScriptでよく見る書き方ができるのですが、そんなことをしているLisperを私は知らないので、my-lisp2ではリストの第一要素にラムダ形式を記述してはいけないことにしています。
```eval.c
static void *eval_list(void *obj, void *env_func, void *env_var) {
    void *car1 = car(obj);
    SYMBOL *symbol;
    char *sym;
    void *obj2;
    if (!listp(obj)) {
        fprintf(stderr, "プロパーなリストではありません");
        state = STATE_ERROR;
        return 0;
    }
    if (!symbolp(car1)) {
        fprintf(stderr, "不正な関数です\n");
        state = STATE_ERROR;
        return 0;
    }
    symbol = (SYMBOL *)car1;
    sym = get_symbol_string(symbol);

    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 {
            fprintf(stderr, "未実装のコードに到達しました\n");
            state = STATE_ERROR;
            return 0;
        }
    } else {
        fprintf(stderr, "%sという名前の関数がありません\n", sym);
        state = STATE_ERROR;
        return 0;
    }
}
```
`eval_symbol`関数はシンボルを評価します。
```eval.c
static void *eval_symbol(void *obj, void *env_func, void *env_var) {
    SYMBOL *symbol = (SYMBOL *)obj;
    char *sym = get_symbol_string(symbol);
    void *retval = 0;
    if (strcmp(sym, "NIL") == 0) {
        return NIL;
    } else if (strcmp(sym, "T") == 0) {
        return T;
    } else if (environment_get_recurse(env_var, symbol, &retval)) {
        return retval;
    } else {
        fprintf(stderr, "%sという名前の変数がありません\n", sym);
        state = STATE_ERROR;
        return 0;
    }
}
```
`register_built_in_func`関数は、グローバル環境に組み込み関数を登録します。
```eval.c
static void register_built_in_func(char *name, void *(* func)(void *)) {
    BUILT_IN_FUNC *f = (BUILT_IN_FUNC *)malloc(sizeof(BUILT_IN_FUNC));
    f->h.type = TYPE_BUILT_IN_FUNC;
    f->f = func;
    environment_add(env_func_global, make_symbol(name), f);
}
```
# built_in_func.h
後述の`built_in_func.c`のプロトタイプ宣言が記述してあります。
# built_in_func.c
このファイルには組み込み関数やスペシャルオペレータなどを記述していきます。インクルード文は省略します。
　`f_add`関数は、`+`関数の実体です。
```built_in_func.c
void *f_add(void *args) {
    double sum = 0.0;
    void *p = args;
    NUMBER *num;
    while (p != NIL) {
        HEADER *h = (HEADER *)car(p);
        if (h->type != TYPE_NUMBER) {
            fprintf(stderr, "FUNCTION \"+\": ");
            printer_print(stderr, car(p));
            fprintf(stderr, "は数値型ではありません\n");
            state = STATE_ERROR;
            return 0;
        }
        num = (NUMBER *)car(p);
        sum += num->num;
        p = cdr(p);
    }
    if (!isfinite(sum)) {
        fprintf(stderr, "FUNCTION \"+\": オーバーフローしました\n");
        state = STATE_ERROR;
        return 0;
    }
    num = (NUMBER *)malloc(sizeof(NUMBER));
    num->h.type = TYPE_NUMBER;
    num->num = sum;
    return (void *)num;
}
```
`f_sub`関数は`-`関数の実体です。`-`関数は`+`関数の「反対」という意味では必ずしもありません。引数が0の時はエラーになるし、引数が1の時には符号が反転します。
```built_in_func.c
void *f_sub(void *args) {
    void *p = args;
    if (args == NIL) {
        fprintf(stderr, "FUNCTION \"-\": 引数の数が0です\n");
        state = STATE_ERROR;
        return 0;
    }
    while (p != NIL) {
        HEADER *h = (HEADER *)car(p);
        if (h->type != TYPE_NUMBER) {
            fprintf(stderr, "FUNCTION \"-\": ");
            printer_print(stderr, car(p));
            fprintf(stderr, "は数値型ではありません\n");
            state = STATE_ERROR;
            return 0;
        }
        p = cdr(p);
    }
    if (cdr(args) == NIL) {
        NUMBER *num1 = (NUMBER *)car(args);
        NUMBER *num2 = (NUMBER *)malloc(sizeof(NUMBER));
        num2->h.type = TYPE_NUMBER;
        num2->num = -num1->num;
        return (void *)num2;
    } else {
        NUMBER *num = (NUMBER *)car(args);
        double acc = num->num;
        p = cdr(args);
        while (p != NIL) {
            num = (NUMBER *)car(p);
            acc -= num->num;
            p = cdr(p);
        }
        if (!isfinite(acc)) {
            fprintf(stderr, "FUNCTION \"-\": オーバーフローしました\n");
            state = STATE_ERROR;
            return 0;
        }
        num = (NUMBER *)malloc(sizeof(NUMBER));
        num->h.type = TYPE_NUMBER;
        num->num = acc;
        return (void *)num;
    }
}
```
`f_mul`関数の定義は`f_add`関数とほぼ同じなので省略します。
`f_div`関数は関数`/`の実体です。`f_sub`関数とほぼ同じなのですが、エラーメッセージが異なるので省略しませんでした。
```built_in_func.c
void *f_div(void *args) {
    void *p = args;
    if (args == NIL) {
        fprintf(stderr, "FUNCTION \"/\": 引数の数が0です\n");
        state = STATE_ERROR;
        return 0;
    }
    while (p != NIL) {
        HEADER *h = (HEADER *)car(p);
        if (h->type != TYPE_NUMBER) {
            fprintf(stderr, "FUNCTION \"/\": ");
            printer_print(stderr, car(p));
            fprintf(stderr, "は数値型ではありません\n");
            state = STATE_ERROR;
            return 0;
        }
        p = cdr(p);
    }
    if (cdr(args) == NIL) {
        NUMBER *num1 = (NUMBER *)car(args);
        double res = 1.0 / num1->num;
        if (!isfinite(res)) {
            fprintf(stderr, "FUNCTION \"/\": ゼロ除算が行われました\n");
            state = STATE_ERROR;
            return 0;
        }
        NUMBER *num2 = (NUMBER *)malloc(sizeof(NUMBER));
        num2->h.type = TYPE_NUMBER;
        num2->num = res;
        return (void *)num2;
    } else {
        NUMBER *num = (NUMBER *)car(args);
        double acc = num->num;
        p = cdr(args);
        while (p != NIL) {
            num = (NUMBER *)car(p);
            acc /= num->num;
            p = cdr(p);
        }
        if (!isfinite(acc)) {
            fprintf(stderr, "FUNCTION \"/\": ゼロ除算が行われました\n");
            state = STATE_ERROR;
            return 0;
        }
        num = (NUMBER *)malloc(sizeof(NUMBER));
        num->h.type = TYPE_NUMBER;
        num->num = acc;
        return (void *)num;
    }
}
```
`f_number_equal`関数は`=`関数の実体です。`f_number_gt`関数、`f_number_ge`関数、`f_number_lt`関数、`f_number_le`関数はそれぞれ、`>`関数、`>=`関数、`<`関数、`<=`関数の実体なのですが、`f_number_equal`関数とほぼ同じなので省略します。
```built_in_func.c
void *f_number_equal(void *args) {
    void *arg1;
    void *arg2;
    NUMBER *num1;
    NUMBER *num2;
    if (list_length(args) != 2) {
        fprintf(stderr, "FUNCTION \"=\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    arg1 = car(args);
    arg2 = car(cdr(args));
    if (((HEADER *)arg1)->type != TYPE_NUMBER) {
        fprintf(stderr, "FUNCTION \"=\": ");
        printer_print(stderr, arg1);
        fprintf(stderr, "は数値型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    if (((HEADER *)arg2)->type != TYPE_NUMBER) {
        fprintf(stderr, "FUNCTION \"=\": ");
        printer_print(stderr, arg2);
        fprintf(stderr, "は数値型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    num1 = (NUMBER *)arg1;
    num2 = (NUMBER *)arg2;
    return (num1->num == num2->num) ? T : NIL;
}
```
関数`f_rem`は関数`rem`の実体であり、これは剰余算を行う関数です。Common Lispには剰余算を行う関数が`mod`と`rem`の2つあり、それぞれの違いは負の値を与えた時に出るという点にご注意ください。また、my-lisp2の作者は剰余算のアルゴリズムに詳しくないので、my-lisp2の`rem`関数はCの`fmod`関数を使っているんだということだけおさえてもらえればと思います。
```built_in_func.c
void *f_rem(void *args) {
    void *arg1;
    void *arg2;
    NUMBER *num1;
    NUMBER *num2;
    double res;
    NUMBER *num;
    if (list_length(args) != 2) {
        fprintf(stderr, "FUNCTION \"REM\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    arg1 = car(args);
    arg2 = car(cdr(args));
    if (((HEADER *)arg1)->type != TYPE_NUMBER) {
        fprintf(stderr, "FUNCTION \"REM\": ");
        printer_print(stderr, arg1);
        fprintf(stderr, "は数値型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    if (((HEADER *)arg2)->type != TYPE_NUMBER) {
        fprintf(stderr, "FUNCTION \"REM\": ");
        printer_print(stderr, arg2);
        fprintf(stderr, "は数値型ではありません\n");
        state = STATE_ERROR;
        return 0;
    }
    num1 = (NUMBER *)arg1;
    num2 = (NUMBER *)arg2;
    res = fmod(num1->num, num2->num);
    if (!isfinite(res)) {
        fprintf(stderr, "FUNCTION \"REM\": ゼロ除算が行われました\n");
        state = STATE_ERROR;
        return 0;
    }
    num = (NUMBER *)malloc(sizeof(NUMBER));
    num->h.type = TYPE_NUMBER;
    num->num = res;
    return (void *)num;
}
```
`helper.c`はmy-lisp2を構築するためのライブラリですが、せっかくなので使えるものは`built_in_func.c`でラッパーを作ることとしました。例えば`f_cons`関数は`helper.c`の`cons`関数のラッパーであり、my-lisp2の`cons`関数の実体です。`f_consp`、`f_car`、`f_cdr`、`f_rplaca`、`f_rplacd`、`f_symbolp`、`f_listp`、`f_list_length`関数も同様のラッパーです。
```built_in_func.c
void *f_cons(void *args) {
    if (list_length(args) != 2) {
        fprintf(stderr, "FUNCTION \"CONS\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    return cons(car(args), car(cdr(args)));
}
```
お見せするまでもない`f_list`関数です。
```built_in_func.c
void *f_list(void *args) {
    return args;
}
```
`f_null`関数は`null`関数の実体です。Common Lispでは`NIL`以外の値は真を表すので、実は`not`関数と同等だったりします。
```built_in_func.c
void *f_null(void *args) {
    if (list_length(args) != 1) {
        fprintf(stderr, "FUNCTION \"NULL\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    return (car(args) == NIL) ? T : NIL;
}
```
`f_exit`関数は`exit`関数の実体です。コメントには`exit`関数の実装がCommon Lispとは異なる、と書いてあるようですが、そもそも`exit`関数は仕様化されていないようです😓。ともかくも、この関数は`state`を`STATE_EXIT`に設定します。そのため正常にアプリを終了できるというわけです。
```built_in_func.c
void *f_exit(void *args) {
    /* 本物のCommon Lispとは仕様が異なる */
    if (list_length(args) != 0) {
        fprintf(stderr, "FUNCTION \"EXIT\": 引数の数が不正です\n");
        state = STATE_ERROR;
        return 0;
    }
    state = STATE_EXIT;
    return 0;
}
```
# helper.c
`listp`関数はフォームがプロパーなリストかどうかを判別します。ドットリストだと偽(`0`)を返します。
```helper.c
int listp(void *obj) {
    while (obj != NIL) {
        if (!consp(obj)) return 0;
        obj = cdr(obj);
    }
    return 1;
}
```
`list_length`関数はリストの長さを返します。元々この関数は、プロパーなリストでない場合は`-1`を返していたのですが、Visual Studioでビルドした時に`size_t`はunsigned型だからダメだというワーニングが発生しました。仕方がないので`f_list_length`では`list_length`の前に`listp`を実行しています。
```helper.c
size_t list_length(void *obj) {
    size_t len = 0;
    while (obj != NIL) {
        if (!consp(obj)) {
            fprintf(stderr, "プロパーなリストではありません\n");
            return 0;
        }
        obj = cdr(obj);
        len++; 
    }
    return len;
}
```
# test.c
評価器の関数呼び出しが追加されています。
```test.c
/*
 * test.c
 */

#include <stdio.h>
#include "../chapter05/state.h"
#include "../chapter08/reader.h"
#include "../chapter07/printer.h"
#include "../chapter09/dot.h"
#include "eval.h"

int main(void) {
    reader_initialize();
    eval_init();
    while (1) {
        printf("> ");
        void *obj = reader_read(stdin);
        if (!obj) {
            if (state == STATE_EXIT) {
                reader_free();
                return 0;
            } else if (state == STATE_ERROR) {
                state = STATE_NORMAL;
                continue;
            } else {
                fprintf(stderr, "未実装のコードに到達しました\n");
                continue;
            }
        }
        fix_to_dotted_list(obj);
        if (!check_single_dot(obj)) {
            fprintf(stderr, "ドットをシンボルとして使用することはできません\n");
            continue;
        }
        obj = eval_top(obj);
        if (!obj) {
            if (state == STATE_EXIT) {
                reader_free();
                return 0;
            } else if (state == STATE_ERROR) {
                state = STATE_NORMAL;
                continue;
            } else {
                fprintf(stderr, "未実装のコードに到達しました\n");
                continue;
            }
        }
        printer_print(stdout, obj);
        fputc('\n', stdout);
    }
    return 0;
}
```
# 動かしてみよう
組み込み関数を実装したので、色々なことができるようになりました。これからが本番！といった感じです。
```
> (+ 1 2 3)
6
> (- 10 2 3)
5
> (* 1 2 3 4 5)
120
> (/ 100 4)
25
> (= 1 1)
T
> (> 2 3)
NIL
> (car (list 1 2 3))
1
> (cdr (list 1 2 3))
(2 3)
> (list-length 1 2 3)
FUNCTION "LIST-LENGTH": 引数の数が不正です
> (list-length (list 1 2 3))
3
> (exit)
```