今回は、評価器を構築し、さらに演算系の関数を実装することで簡易的な電卓を作ります。
ソースコード

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)