6 #include "util_const.h"
7 #include "util_string.h"
11 static MNode* symquote (MNode* v) {
16 && v->sym->length () > 0
17 && ((*v->sym)[0] == '#' || (*v->sym)[0] == ':')) {
19 v = newMNode_quote (v);
23 v = newMNode_quote (v);
36 (quote LIST...) -> LIST
39 //#AFUNC quote ml_quote
41 MNode* ml_quote (MNode* cell, MlEnv* mlenv) {
42 MNode* arg = cell->cdr ();
45 throw (uErrorWrongNumber);
48 switch (arg->car ()->type) {
52 return mlenv->retval = arg->car ();
60 (list LIST...) -> LIST
65 MNode* ml_list (MNode* cell, MlEnv* mlenv) {
66 MNode* arg = cell->cdr ();
70 ans.append (eval (arg->car (), mlenv));
73 return ans.release ();
78 (if EXPR THEN_FUNCTION ELSE_FUNCTION_BODY...) -> LAST VALUE
83 MNode* ml_if (MNode* cell, MlEnv* mlenv) {
84 MNode* arg = cell->cdr ();
89 r = eval_bool (arg->car (), mlenv);
90 if (mlenv->breaksym ())
91 return mlenv->breakval ();
96 mlenv->logSexp (arg->car ());
98 ans = eval (arg->car (), mlenv);
103 ans = progn (arg, mlenv);
104 // ifは対象でない mlenv->stopBreak (cell->car ());
108 return ans.release ();
113 (cond (EXPR BODY...)...) -> LAST VALUE
116 //#AFUNC cond ml_cond
118 MNode* ml_cond (MNode* cell, MlEnv* mlenv) {
119 MNode* arg = cell->cdr ();
124 while (arg && ! mlenv->breaksym ()) {
127 throw (uNil + uErrorBadType);
129 throw (a->dump_string () + uErrorBadType);
130 f = eval_bool (a->car (), mlenv);
131 if (mlenv->breaksym ()) {
132 ans = mlenv->breakval ();
133 // condは対象ではない mlenv->stopBreak (cell->car ());
137 ans = progn (a->cdr (), mlenv);
138 // condは対象ではない mlenv->stopBreak (cell->car ());
144 return ans.release ();
149 (progn [:on-error FUNCTION] BODY...) -> LAST VALUE
152 //#AFUNC progn ml_progn
154 MNode* ml_progn (MNode* cell, MlEnv* mlenv) {
155 MNode* arg = cell->cdr ();
158 std::vector<MNode*> keywords;
160 static paramList kwlist[] = {
161 {CharConst ("on-error"), false},
165 setParams (arg, 0, NULL, kwlist, &keywords, &rest);
167 errfn = eval (keywords[0], mlenv);
170 ans = progn (rest, mlenv);
171 } catch (ustring& msg) {
173 onErrorFn (errfn (), mlenv);
178 mlenv->stopBreak (cell->car ());
180 return ans.release ();
184 ===select, case, otherwise===
191 //#AFUNC select ml_select
193 //#AFUNC case ml_case
195 //#AFUNC otherwise ml_otherwise
196 //#WIKIFUNC otherwise
197 MNode* ml_select (MNode* cell, MlEnv* mlenv) {
198 MNode* arg = cell->cdr ();
201 while (arg && ! mlenv->breaksym ()) {
203 mlenv->logSexp (arg->car ());
205 ans = eval (arg->car (), mlenv);
206 if (mlenv->breaksym ()) {
207 ans = mlenv->breakval ();
208 // 対象外 mlenv->stopBreak (cell->car ());
209 return ans.release ();
213 if (ans ()->isCons () && to_bool (ans ()->car ())) {
214 ans = ans ()->cdr ();
215 return ans.release ();
224 MNode* ml_case (MNode* cell, MlEnv* mlenv) {
225 MNode* arg = cell->cdr ();
230 throw (uErrorWrongNumber);
232 r = eval_bool (arg->car (), mlenv);
236 ans ()->set_car (newMNode_bool (true));
237 ans ()->set_cdr (progn (arg, mlenv));
238 // mlenv->stopBreak (cell->car ());
241 return ans.release ();
244 MNode* ml_otherwise (MNode* cell, MlEnv* mlenv) {
245 MNode* arg = cell->cdr ();
249 ans ()->set_car (newMNode_bool (true));
250 ans ()->set_cdr (progn (arg, mlenv));
251 // mlenv->stopBreak (cell->car ());
253 return ans.release ();
258 (repeat VARIABLE FROM TO [:step ADD] [:array VARLIST] BODY...) -> LAST VALUE
260 index VARIABLE is set local.
263 //#AFUNC repeat ml_repeat
264 MNode* ml_repeat (MNode* cell, MlEnv* mlenv) {
265 MNode* arg = cell->cdr ();
270 std::vector<ustring> lv;
276 std::vector<MNode*> params;
277 std::vector<MNode*> keywords;
279 static paramList kwlist[] = {
280 {CharConst ("step"), false},
281 {CharConst ("array"), false},
285 setParams (arg, 3, ¶ms, kwlist, &keywords, &rest);
286 iv = eval_str (params[0], mlenv);
287 from = eval_double (params[1], mlenv);
288 to = eval_double (params[2], mlenv);
290 step = eval_double (keywords[0], mlenv);
294 if (a && a->isSym ()) {
295 lv.push_back (a->to_string ());
296 } else if (a && a->isCons ()) {
298 lv.push_back (to_string (a->car ()));
302 throw (to_string (t ()) + ustring (": bad argument."));
307 AutoLocalVariable autoLocal (mlenv);
309 mlenv->defineLocalVar (iv);
313 for (i = from; kp && i <= to; i += step) {
314 t = newMNode_num (i);
315 mlenv->setVar (iv, t ());
317 for (j = 0; j < lv.size (); j ++)
318 mlenv->setVar (lv[j], mlenv->getAry (lv[j], (size_t)i));
319 ans = progn (rest, mlenv);
320 if (mlenv->breaksym ()) {
321 mlenv->stopBreak (cell->car ());
325 for (j = 0; j < lv.size (); j ++)
326 mlenv->setAry (lv[j], (size_t)i, mlenv->getVar (lv[j]));
328 if (mlenv->qtimeup ())
332 } else if (step < 0) {
334 for (i = from; kp && i >= to; i += step) {
335 t = newMNode_num (i);
336 mlenv->setVar (iv, t ());
338 for (j = 0; j < lv.size (); j ++)
339 mlenv->setVar (lv[j], mlenv->getAry (lv[j], (size_t)i));
340 ans = progn (rest, mlenv);
341 if (mlenv->breaksym ()) {
342 mlenv->stopBreak (cell->car ());
346 for (j = 0; j < lv.size (); j ++)
347 mlenv->setAry (lv[j], (size_t)i, mlenv->getVar (lv[j]));
349 if (mlenv->qtimeup ())
356 return mlenv->retval = ans ();
361 (doarray '(ARRAY_VARIABLE ...) [:index VARIABLE] [:setvar '(VARIABLE...)] BODY...) -> LAST VALUE
363 index VARIABLE is set local.
366 //#AFUNC doarray ml_doarray
367 MNode* ml_doarray (MNode* cell, MlEnv* mlenv) {
368 MNode* arg = cell->cdr ();
369 std::vector<ustring> lv;
370 std::vector<ustring> setvar;
378 std::vector<MNode*> params;
379 std::vector<MNode*> keywords;
381 static paramList kwlist[] = {
382 {CharConst ("index"), false},
383 {CharConst ("setvar"), false},
387 setParams (arg, 1, ¶ms, kwlist, &keywords, &rest);
388 t = eval (params[0], mlenv);
389 if (t () && t ()->isSym ()) {
390 lv.push_back (t ()->to_string ());
391 } else if (t () && t ()->isCons ()) {
393 while (a && a->isCons ()) {
394 lv.push_back (to_string (a->car ()));
398 throw (dump_to_sexp (t ()) + ustring (": bad argument."));
401 iv = to_string (t ());
403 if (t () && t ()->isSym ()) {
404 setvar.push_back (to_string (t ()));
405 } else if (t () && t ()->isCons ()) {
407 while (a && a->isCons ()) {
408 setvar.push_back (to_string (a->car ()));
412 throw (ustring (CharConst (":setvar ")) + dump_to_sexp (t ()) + ustring (": bad argument."));
417 AutoLocalVariable autoLocal (mlenv);
419 if (iv.length () > 0)
420 mlenv->defineLocalVar (iv);
423 nsv = setvar.size ();
424 if (nsv > 0 && nlv > nsv)
429 n = mlenv->getArySize (lv[0]);
430 for (i = 1; kp && i <= n; i ++) {
432 for (it = 0; it < nlv; it ++) {
433 mlenv->setVar (lv[it], mlenv->getAry (lv[it], i));
436 for (it = 0; it < nlv; it ++) {
437 mlenv->setVar (setvar[it], mlenv->getAry (lv[it], i));
439 for (; it < nsv; it ++) {
440 mlenv->setVar (setvar[it], NULL);
443 if (iv.size () > 0) {
444 t = newMNode_num (i);
445 mlenv->setVar (iv, t ());
447 ans = progn (rest, mlenv);
448 if (mlenv->breaksym ()) {
449 mlenv->stopBreak (cell->car ());
453 for (it = 0; it < nlv; it ++) {
454 mlenv->setAry (lv[it], i, mlenv->getVar (lv[it]));
457 for (it = 0; it < nlv; it ++) {
458 mlenv->setAry (lv[it], i, mlenv->getVar (setvar[it]));
462 for (it = 0; it < nlv; it ++) {
463 mlenv->setArySize (lv[it], n);
468 return ans.release ();
473 (dolist '(VARIABLE1...) '(LIST...) [:index VARIABLE2] BODY...) -> LAST VALUE
475 list VARIABLE1 and index VARIABLE2 is set local.
478 //#AFUNC dolist ml_dolist
479 MNode* ml_dolist (MNode* cell, MlEnv* mlenv) {
480 MNode* arg = cell->cdr ();
481 std::vector<ustring> lv;
486 std::vector<MNode*> llv;
492 std::vector<MNode*> params;
493 std::vector<MNode*> keywords;
495 static paramList kwlist[] = {
496 {CharConst ("index"), false},
500 setParams (arg, 2, ¶ms, kwlist, &keywords, &rest);
501 vlist = eval (params[0], mlenv);
502 if (vlist () && vlist ()->isSym ()) {
503 lv.push_back (vlist ()->to_string ());
504 } else if (vlist () && vlist ()->isCons ()) {
506 while (a && a->isCons ()) {
507 lv.push_back (to_string (a->car ()));
511 throw (to_string (vlist ()) + ustring (": bad argument."));
513 list = eval (params[1], mlenv);
515 iv = eval_str (keywords[0], mlenv);
519 for (i = 0; i < iu; i ++) {
521 llv.push_back (a->car ());
523 llv.push_back (NULL);
528 AutoLocalVariable autoLocal (mlenv);
530 for (it = 0; it < iu; it ++)
531 mlenv->defineLocalVar (lv[it]);
532 if (iv.length () > 0)
533 mlenv->defineLocalVar (iv);
535 if (iu > 0 && llv.size () > 0) {
537 for (i = 1; kp && llv[0]; i ++) {
538 if (iv.length () > 0) {
539 mlenv->setVar (iv, newMNode_num (i));
541 for (it = 0; it < iu; it ++) {
543 mlenv->setVar (lv[it], llv[it]->car ());
545 mlenv->setVar (lv[it], NULL);
548 ans = progn (rest, mlenv);
549 if (mlenv->breaksym ()) {
550 mlenv->stopBreak (cell->car ());
557 return ans.release ();
562 (while EXPR BODY...) -> LAST VALUE
565 //#AFUNC while ml_while
566 MNode* ml_while (MNode* cell, MlEnv* mlenv) {
567 MNode* arg = cell->cdr ();
574 while (eval_bool (exp, mlenv)) {
575 ans = progn (arg, mlenv);
576 if (mlenv->breaksym ()) {
577 mlenv->stopBreak (cell->car ());
582 return ans.release ();
587 (break FUNCTION-NAME VALUE) -> NULL
590 //#AFUNC break ml_break
591 MNode* ml_break (MNode* cell, MlEnv* mlenv) {
592 MNode* arg = cell->cdr ();
599 sym = eval (arg->car (), mlenv);
602 val = eval (arg->car (), mlenv);
605 throw (uErrorWrongNumber);
608 mlenv->setBreak (sym.release (), val ());
610 return mlenv->retval = val.release ();
618 //#AFUNC exit ml_exit
619 MNode* ml_exit (MNode* cell, MlEnv* mlenv) {
620 MNode* arg = cell->cdr ();
623 throw (uErrorWrongNumber);
632 (apply FUNCTION-NAME VALUE... LIST) -> ANY
633 (apply LAMBDA VALUE... LIST) -> ANY
636 //#AFUNC apply ml_apply
637 MNode* ml_apply (MNode* cell, MlEnv* mlenv) {
638 MNode* arg = cell->cdr ();
644 throw (uErrorWrongNumber);
645 fn = eval (arg->car (), mlenv);
648 throw (uErrorSyntax);
649 } else if (isLambda (fn ())) {
651 if (! isNil (arg->cdr ())) {
652 list.append (eval (arg->car (), mlenv));
655 h = eval (arg->car (), mlenv);
657 while (a && a->isCons ()) {
658 list.append (a->car ());
664 return mlenv->retval = execDefun (mlenv, fn (), list (), uEmpty);
665 } else if (fn ()->isSym ()) {
667 if (! isNil (arg->cdr ())) {
668 list.append (symquote (eval (arg->car (), mlenv)));
671 h = eval (arg->car (), mlenv);
673 while (a && a->isCons ()) {
674 list.append (symquote (a->car ()));
683 f ()->set_car (fn ());
684 f ()->set_cdr (list ());
685 return mlenv->retval = eval (f (), mlenv);
687 throw (uErrorSyntax);
694 (funcall LAMBDA PARAMS...)
697 //#AFUNC funcall ml_funcall
698 MNode* ml_funcall (MNode* cell, MlEnv* mlenv) {
699 MNode* arg = cell->cdr ();
703 throw (uErrorWrongNumber);
704 fn = eval (arg->car (), mlenv);
708 throw (uErrorSyntax);
709 } else if (isLambda (fn ())) {
710 return mlenv->retval = execDefun (mlenv, fn (), arg, uEmpty);
711 } else if (fn ()->isSym ()) {
714 f ()->set_car (fn ());
716 return mlenv->retval = eval (f (), mlenv);
718 throw (uErrorSyntax);
728 //#AFUNC eval ml_eval
729 MNode* ml_eval (MNode* cell, MlEnv* mlenv) {
730 MNode* arg = cell->cdr ();
734 throw (uErrorWrongNumber);
735 h = eval (arg->car (), mlenv);
738 throw (uErrorWrongNumber);
739 return mlenv->retval = eval (h (), mlenv);
749 MNode* ml_car (MNode* cell, MlEnv* mlenv) {
750 MNode* arg = cell->cdr ();
754 throw (uErrorWrongNumber);
755 h = eval (arg->car (), mlenv);
758 throw (uErrorWrongNumber);
760 if (h () && h ()->isCons ()) {
761 return mlenv->retval = h ()->car ();
774 MNode* ml_cdr (MNode* cell, MlEnv* mlenv) {
775 MNode* arg = cell->cdr ();
779 throw (uErrorWrongNumber);
780 h = eval (arg->car (), mlenv);
783 throw (uErrorWrongNumber);
785 if (h () && h ()->isCons ()) {
786 return mlenv->retval = h ()->cdr ();
799 MNode* ml_nth (MNode* cell, MlEnv* mlenv) {
800 MNode* arg = cell->cdr ();
806 throw (uErrorWrongNumber);
807 n = eval_int (arg->car (), mlenv);
809 h = eval (arg->car (), mlenv);
812 throw (uErrorWrongNumber);
815 while (n > 0 && a && a->isCons ()) {
820 if (a && a->isCons ())
821 return mlenv->retval = a->car ();
829 (replca CELL NEWCAR) -> NEWCAR
832 //#AFUNC replca ml_replca
833 MNode* ml_replca (MNode* cell, MlEnv* mlenv) {
834 MNode* arg = cell->cdr ();
839 throw (uErrorWrongNumber);
840 c = eval (arg->car (), mlenv);
841 nextNodeNonNil (arg);
842 newcar = eval (arg->car (), mlenv);
845 throw (uErrorWrongNumber);
848 throw (ustring (CharConst ("nil data.")));
849 if (! c ()->isCons ())
850 throw (c ()->dump_string () + uErrorBadType);
852 c ()->set_car (newcar ());
854 return mlenv->retval = newcar ();
859 (replcd CELL NEWCDR) -> NEWCDR
862 //#AFUNC replcd ml_replcd
863 MNode* ml_replcd (MNode* cell, MlEnv* mlenv) {
864 MNode* arg = cell->cdr ();
869 throw (uErrorWrongNumber);
870 c = eval (arg->car (), mlenv);
871 nextNodeNonNil (arg);
872 newcdr = eval (arg->car (), mlenv);
875 throw (uErrorWrongNumber);
878 throw (ustring (CharConst ("nil data.")));
879 if (! c ()->isCons ())
880 throw (c ()->dump_string () + uErrorBadType);
882 c ()->set_cdr (newcdr ());
884 return mlenv->retval = newcdr ();
889 (cons CAR CDR) -> CONS
892 //#AFUNC cons ml_cons
894 MNode* ml_cons (MNode* cell, MlEnv* mlenv) {
895 MNode* arg = cell->cdr ();
901 throw (uErrorWrongNumber);
902 car = eval (arg->car (), mlenv);
905 cdr = eval (arg->car (), mlenv);
909 throw (uErrorWrongNumber);
912 ans ()->set_car (car ());
913 ans ()->set_cdr (cdr ());
915 return mlenv->retval = ans ();
920 (append LIST...) -> LIST
923 //#AFUNC append ml_append
925 MNode* ml_append (MNode* cell, MlEnv* mlenv) {
926 MNode* arg = cell->cdr ();
932 h = eval (arg->car (), mlenv);
936 while (a && a->isCons ()) {
937 list.append (a->car ());
941 list.set_cdr_cut (h ());
945 return mlenv->retval = list ();
950 (mapcar LAMBDA LIST...) -> LIST
953 //#AFUNC mapcar ml_mapcar
955 MNode* ml_mapcar (MNode* cell, MlEnv* mlenv) {
956 MNode* arg = cell->cdr ();
964 throw (uErrorWrongNumber);
965 fn = eval (arg->car (), mlenv);
966 nextNodeNonNil (arg);
968 list.append (eval (arg->car (), mlenv));
973 throw (uErrorSyntax);
974 } else if (isLambda (fn ())) {
975 } else if (fn ()->isSym ()) {
977 throw (uErrorSyntax);
982 if (fn ()->isSym ()) {
989 if (h () && h ()->isCons ()) {
990 e.append (newMNode_quote (h ()->car ()));
992 arg->set_car (h ()->cdr ());
1002 h ()->set_car (fn ());
1003 h ()->set_cdr (e.release ());
1004 ans.append (eval (h (), mlenv));
1013 if (h () && h ()->isCons ()) {
1014 e.append (h ()->car ());
1016 arg->set_car (h ()->cdr ());
1025 ans.append (execDefun (mlenv, fn (), e (), uEmpty));
1029 return ans.release ();
1033 ===mapcar-collect===
1034 (mapcar-collect LAMBDA LIST...) -> LIST
1037 //#AFUNC mapcar-collect ml_mapcar_collect
1038 //#WIKIFUNC mapcar-collect
1039 MNode* ml_mapcar_collect (MNode* cell, MlEnv* mlenv) {
1040 MNode* arg = cell->cdr ();
1049 throw (uErrorWrongNumber);
1050 fn = eval (arg->car (), mlenv);
1051 nextNodeNonNil (arg);
1053 list.append (eval (arg->car (), mlenv));
1058 throw (uErrorSyntax);
1059 } else if (isLambda (fn ())) {
1060 } else if (fn ()->isSym ()) {
1062 throw (uErrorSyntax);
1064 if (isNil (list ()))
1067 if (fn ()->isSym ()) {
1074 if (h () && h ()->isCons ()) {
1075 e.append (newMNode_quote (h ()->car ()));
1077 arg->set_car (h ()->cdr ());
1087 h ()->set_car (fn ());
1088 h ()->set_cdr (e.release ());
1089 v = eval (h (), mlenv);
1091 ans.append (v.release ());
1100 if (h () && h ()->isCons ()) {
1101 e.append (h ()->car ());
1103 arg->set_car (h ()->cdr ());
1112 v = execDefun (mlenv, fn (), e (), uEmpty);
1114 ans.append (v.release ());
1118 return ans.release ();
1125 (member ELT LIST) -> LIST
1127 Return 1 if LIST contaions ELT. The comparison is done by ===.
1130 //#AFUNC member ml_member
1132 MNode* ml_member (MNode* cell, MlEnv* mlenv) {
1133 MNode* arg = cell->cdr ();
1138 throw (uErrorWrongNumber);
1139 elt = eval (arg->car (), mlenv);
1141 list = eval (arg->car (), mlenv);
1144 throw (uErrorWrongNumber);
1148 if (eq (elt (), arg->car ())) {
1149 return newMNode_bool (true);
1158 (memberp LAMBDA LIST) -> LIST
1160 Return first cdr of LIST that the LAMBDA applied the element returns true.
1163 //#AFUNC memberp ml_memberp
1165 MNode* ml_memberp (MNode* cell, MlEnv* mlenv) {
1166 MNode* arg = cell->cdr ();
1171 throw (uErrorWrongNumber);
1172 fn = eval (arg->car (), mlenv);
1174 list = eval (arg->car (), mlenv);
1177 throw (uErrorWrongNumber);
1180 throw (uErrorSyntax);
1181 } else if (isLambda (fn ())) {
1182 } else if (fn ()->isSym ()) {
1184 throw (uErrorSyntax);
1188 if (fn ()->isSym ()) {
1190 sexp = new MNode ();
1191 sexp ()->set_car (fn ());
1192 MNode* q = new MNode ();
1193 sexp ()->set_cdr (q);
1197 q->set_car (eval (arg->car (), mlenv));
1198 if (eval_bool (sexp (), mlenv))
1206 h ()->set_car (arg->car ());
1207 h = execDefun (mlenv, fn (), h (), uEmpty);
1218 (reverse LIST) -> LIST
1221 //#AFUNC reverse ml_reverse
1223 MNode* ml_reverse (MNode* cell, MlEnv* mlenv) {
1224 MNode* arg = cell->cdr ();
1230 throw (uErrorWrongNumber);
1231 a = eval (arg->car (), mlenv);
1234 throw (uErrorWrongNumber);
1236 if (! a () || ! a ()->isCons ()) {
1239 while (a () && a ()->isCons ()) {
1241 c->set_car (a ()->car ());
1242 c->set_cdr (ans ());
1248 return mlenv->retval = ans.release ();