今回はdoなどのループ系マクロを作っていきます。で、申し訳ないのですが、setqを書き直さなければなりません。psetqは追加で必要となります。doの定義に必要になるためですね。
ソースコード
built_in_func.c
op_setq関数はスペシャルオペレーターsetqの実体です。前と違うところは、複数の変数に代入できるようになっているところです。
built_in_func.c
void *op_setq(void *args, void *env_func, void *env_var) {
void *val = NIL;
if (list_length(args) % 2 != 0) {
fprintf(stderr, "SETQ: 引数の数が不正です\n");
state = STATE_ERROR;
return 0;
}
while (args != NIL) {
if (!symbolp(car(args))) {
fprintf(stderr, "SETQ: 奇数個目の引数がシンボル型ではありません\n");
state = STATE_ERROR;
return 0;
}
val = eval(car(cdr(args)), env_func, env_var);
if (!val) return 0;
if (!environment_exists_recurse(env_var, car(args))) {
fprintf(stderr, "SETQ: %sという名前の変数はありません\n",
get_symbol_string(car(args)));
state = STATE_ERROR;
return 0;
}
environment_modify_recurse(env_var, car(args), val);
args = cdr(cdr(args));
}
return val;
}
op_psetq関数はスペシャルオペレーターpsetqの実体です。psetqはsetqほど簡単ではありません。実行には追加のコストがかかります。
built_in_func.c
void *op_psetq(void *args, void *env_func, void *env_var) {
void *val = NIL;
void *p;
CONS_BUFFER cbuf;
void *val_list;
if (list_length(args) % 2 != 0) {
fprintf(stderr, "SETQ: 引数の数が不正です\n");
state = STATE_ERROR;
return 0;
}
cbuf = cons_buffer_allocate();
p = args;
while (p != NIL) {
if (!symbolp(car(p))) {
fprintf(stderr, "PSETQ: 奇数個目の引数がシンボル型ではありません\n");
cons_buffer_free(cbuf);
state = STATE_ERROR;
return 0;
}
val = eval(car(cdr(p)), env_func, env_var);
if (!val) return 0;
cons_buffer_add(cbuf, val);
p = cdr(cdr(p));
}
val_list = cons_buffer_get_list(cbuf);
cons_buffer_free(cbuf);
p = args;
while (p != NIL) {
if (!environment_exists_recurse(env_var, car(p))) {
fprintf(stderr, "PSETQ: %sという名前の変数はありません\n",
get_symbol_string(car(p)));
state = STATE_ERROR;
return 0;
}
environment_modify_recurse(env_var, car(p), car(val_list));
p = cdr(cdr(p));
val_list = cdr(val_list);
}
return val;
}
動かしてみよう
まず、my-lisp2用のライブラリlib.lispです。
lib.lisp
; my-lisp2のライブラリ(Common Lispの処理系に読み込ませるとエラーになる)
(defun first (list) (car list))
(defun second (list) (car (cdr list)))
(defun third (list) (car (cdr (cdr list))))
(defun rest (list) (cdr list))
(defun 1+ (number) (+ number 1))
(defun 1- (number) (- number 1))
(defun not (x) (null x))
(defun 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 mapcar (func list)
(let ((rest list) (res nil))
(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 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)))))
(defun append (&rest lists)
(let ((ls (reverse (mapcar #'reverse lists)))
(rest)
(res nil))
(block nil
(tagbody
a
(if (null ls) (return-from nil res))
(setq rest (first ls))
(tagbody
b
(if (null rest) (go bend))
(setq res (cons (first rest) res))
(setq rest (rest rest))
(go b)
bend)
(setq ls (rest ls))
(go a)))))
(defmacro 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 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 return (retval)
(list 'return-from nil retval))
(defmacro 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)))
次に、今回テストするコードtmp.lispです。
tmp.lisp
(defmacro my-do (var-list test-&-result &rest statements)
(let ((vlist1 (reverse var-list))
(vlist2 nil)
(slist nil) ; step-form-list
(vis) ; var / init-form / step-form
(jump-label (gensym)))
(tagbody
loop1
(if (null vlist1) (go loopend1))
(setq vis (first vlist1))
(cond
((symbolp vis)
(setq vlist2 (cons (list vis nil) vlist2)))
((= (list-length vis) 1)
(setq vlist2 (cons (list (first vis) nil) vlist2)))
((= (list-length vis) 2)
(setq vlist2 (cons vis vlist2)))
(t
(setq vlist2 (cons (list (first vis) (second vis)) vlist2))
(setq slist (cons (first vis) (cons (third vis) slist)))))
(setq vlist1 (rest vlist1))
(go loop1)
loopend1)
(list 'let vlist2
(list 'block nil
(append
(list 'tagbody
jump-label
(list 'if
(first test-&-result)
(list 'return-from
nil
(cons 'progn (rest test-&-result)))))
statements
(list (cons 'psetq slist)
(list 'go jump-label)))))))
(defmacro my-do* (var-list test-&-result &rest statements)
(let ((vlist1 (reverse var-list))
(vlist2 nil)
(slist nil) ; step-form-list
(vis) ; var / init-form / step-form
(jump-label (gensym)))
(tagbody
loop1
(if (null vlist1) (go loopend1))
(setq vis (first vlist1))
(cond
((symbolp vis)
(setq vlist2 (cons (list vis nil) vlist2)))
((= (list-length vis) 1)
(setq vlist2 (cons (list (first vis) nil) vlist2)))
((= (list-length vis) 2)
(setq vlist2 (cons vis vlist2)))
(t
(setq vlist2 (cons (list (first vis) (second vis)) vlist2))
(setq slist (cons (first vis) (cons (third vis) slist)))))
(setq vlist1 (rest vlist1))
(go loop1)
loopend1)
(list 'let* vlist2
(list 'block nil
(append
(list 'tagbody
jump-label
(list 'if
(first test-&-result)
(list 'return-from
nil
(cons 'progn (rest test-&-result)))))
statements
(list (cons 'setq slist)
(list 'go jump-label)))))))
(defmacro my-dotimes (var-spec &rest statements)
(let ((var (first var-spec))
(count-form (second var-spec))
(result-form (third var-spec))
(end-val (gensym)))
(append
(list 'my-do*
(list (list var 0 (list '1+ var))
(list end-val count-form))
(list (list '= var end-val) result-form))
statements)))
(defmacro my-dolist (var-spec &rest statements)
(let ((var (first var-spec))
(list-form (second var-spec))
(result-form (third var-spec))
(list-var (gensym)))
(append
(list 'my-do*
(list (list list-var list-form (list 'cdr list-var))
(list var (list 'car list-var) (list 'car list-var)))
(list (list 'null list-var) result-form))
statements)))
結果は以下のとおりです。
> (load "lib.lisp")
T
> (load "tmp.lisp")
T
> (my-do ((a 0 b) (b 1 (+ a b))) ((>= a 100)) (print a))
0
1
1
2
3
5
8
13
21
34
55
89
NIL
> (my-do* ((x 1 (1+ x)) (sum 0)) ((> x 10) sum) (setq sum (+ sum x)))
55
> (let ((acc 1)) (my-dotimes (x 10 acc) (setq acc (* acc 2))))
1024
> (my-dolist (x (list 1 2 3 4)) (print x))
1
2
3
4
NIL