マクロシステムを評価器に組み込んで、実際にマクロを動かしてやります。とはいえ、そんなに難しいことはありませんのでご安心ください。
ソースコード
type.h
データ型にマクロ型を追加しました。
type.h
#define TYPE_MACRO 7
type.h
typedef struct MACRO {
HEADER h;
void *body;
void *env_func;
void *env_var;
} MACRO;
eval.c
eval_list関数の中でexpand_macro関数を呼び出しています。
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 if (h->type == TYPE_MACRO) {
return expand_macro(
symbol, obj2, 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;
}
}
expand_macro関数の内部でマクロを展開しています。マクロ展開は複数回行わなければならないこともありますが、一番最後にeval関数を呼び出すことでそのようなシチュエーションにも対応しております。そして&RESTキーワードに対応している分長くなっています（この苦労は後で報われます）。
eval.c
static void *expand_macro(
void *name, void *macro, void *args, void *env_func, void *env_var) {
MACRO *m = (MACRO *)macro;
void *arglist = car(m->body);
int has_rest_param = find_symbol("&REST", arglist);
void *p;
void *new_env_var;
void *retval;
if (has_rest_param) {
if (list_length(args) < list_length(arglist) - 2) {
fprintf(stderr, "MACRO \"%s\": 引数の数が一致しません\n",
get_symbol_string(name));
state = STATE_ERROR;
return 0;
}
} else {
if (list_length(args) != list_length(arglist)) {
fprintf(stderr, "MACRO \"%s\": 引数の数が一致しません\n",
get_symbol_string(name));
state = STATE_ERROR;
return 0;
}
}
new_env_var = environment_init(m->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(m->body); p != NIL; p = cdr(p)) {
retval = eval(car(p), m->env_func, new_env_var);
if (!retval) return 0;
}
return eval(retval, env_func, env_var);
}
built_in_func.c
op_defmacroはスペシャルオペレーターdefmacroの実体です。実は&BODYキーワードには対応しようかとも思ったのですが、行数が増えるのでやめました。あとmacroletも実装しませんでした。そこまで頑張る必要もないかと思いましたので。
built_in_func.c
void *op_defmacro(void *args, void *env_func, void *env_var) {
void *name = car(args);
void *arglist = car(cdr(args));
void *p;
MACRO *m;
if (!symbolp(name)) {
fprintf(stderr, "DEFMACRO: 関数名がシンボルではありません\n");
state = STATE_ERROR;
return 0;
}
if (!listp(arglist)
|| !all_symbol_p(arglist)
|| !unique_symbol_list_p(arglist)) {
fprintf(stderr, "DEFMACRO: 引数リストが不正な形式です\n");
state = STATE_ERROR;
return 0;
}
if (find_symbol("&OPTIONAL", arglist)
|| find_symbol("&KEY", arglist)
|| find_symbol("&AUX", arglist)
|| find_symbol("&ALLOW-OTHER-KEYS", arglist)
|| find_symbol("&BODY", arglist)
|| find_symbol("&ENVIRONMENT", arglist)
|| find_symbol("&WHOLE", arglist)) {
fprintf(stderr, "DEFMACRO: 非対応のキーワードです\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, "DEFMACRO: &RESTが不正な場所にあります\n");
state = STATE_ERROR;
return 0;
}
m = (MACRO *)malloc(sizeof(MACRO));
m->h.type = TYPE_MACRO;
m->body = cdr(args);
m->env_func = env_func;
m->env_var = env_var;
if (environment_exists(env_func_global, name)) {
environment_modify(env_func_global, name, m);
} else {
environment_add(env_func_global, name, m);
}
return name;
}
動かしてみよう
今まで定義してきた組み込み関数だけだとちょっと物足りないので、my-lisp2用のライブラリを作りました。
lib.lisp
; my-lisp2のライブラリ(Common Lispの処理系に読み込ませるとエラーになる)
(defun first (list) (car list))
(defun second (list) (car (cdr list)))
(defun rest (list) (cdr list))
(defun 1+ (number) (+ number 1))
(defun 1- (number) (- number 1))
(defun not (x) (null x))
今回実装したマクロはtmp.lispに書きました。
tmp.lisp
(defmacro my-and (&rest conds)
(let ((len (list-length conds)))
(if (= len 0) T
(if (= len 1) (first conds)
(labels
((f (conds len)
(if (= len 2)
(list 'if (first conds) (second conds))
(list 'if (first conds) (f (rest conds) (1- len))))))
(f conds len))))))
(defmacro my-or (&rest conds)
(let ((len (list-length conds)))
(if (= len 0) NIL
(labels
((f (conds len)
(if (= len 1)
(first conds)
(let ((var (gensym)))
(list 'let (list (list var (first conds)))
(list 'if
var
var
(f (rest conds) (1- len))))))))
(f conds len)))))
(defmacro my-return (retval)
(list 'return-from nil retval))
(defmacro my-cond (&rest test-&-forms-list)
(labels ((f (test-&-forms-list)
(if (null test-&-forms-list)
nil
(let* ((test-&-forms (first test-&-forms-list))
(test (first test-&-forms))
(forms (rest test-&-forms))
(len (list-length forms))
(smaller (f (rest test-&-forms-list))))
(if (not (consp test-&-forms))
(error "COND: 引数がリストではありません")
(if (null forms)
(let ((var (gensym)))
(list 'let (list (list var test))
(list 'if var var smaller)))
(if (= len 1)
(list 'if test (first forms) smaller)
(list 'if test (cons 'progn forms) smaller))))))))
(f test-&-forms-list)))
うまくいったようです。
> (load "lib.lisp")
T
> (load "tmp.lisp")
T
> (my-and 1 2 3)
3
> (my-or 1 2 3)
1
> (my-cond (1) (2 3))
1
> (my-cond (1 2) (3 4))
2
> (my-cond (nil 1) (2 3))
3