modules/ml-struct.cc

   1 #include "ml-struct.h"
   2 #include "ml.h"
   3 #include "mlenv.h"
   4 #include "motorenv.h"
   5 #include "expr.h"
   6 #include "util_const.h"
   7 #include "util_string.h"
   8 #include "ustring.h"
   9 #include <exception>
  10
  11 /*DOC:
  12 ==lisp structure==
  13
  14 */
  15 /*DOC:
  16 ===quote===
  17  (quote LIST...) -> LIST
  18
  19 */
  20 //#AFUNC        quote   ml_quote
  21 //#WIKIFUNC     quote
  22 MNode*  ml_quote (MNode* cell, MlEnv* mlenv) {
  23     MNode*  arg = cell->cdr ();
  24
  25     if (! arg)
  26         throw (uErrorWrongNumber);
  27
  28     if (arg->car ()) {
  29         switch (arg->car ()->type) {
  30         case MNode::MC_NIL:
  31             return NULL;
  32         default:
  33             return mlenv->retval = arg->car ();
  34         }
  35     }
  36     return NULL;
  37 }
  38
  39 /*DOC:
  40 ===list===
  41  (list LIST...) -> LIST
  42
  43 */
  44 //#AFUNC        list    ml_list
  45 //#WIKIFUNC     list
  46 MNode*  ml_list (MNode* cell, MlEnv* mlenv) {
  47     MNode*  arg = cell->cdr ();
  48     MNodeList  ans;
  49
  50     while (arg) {
  51         ans.append (eval (arg->car (), mlenv));
  52         nextNode (arg);
  53     }
  54     return ans.release ();
  55 }
  56
  57 /*DOC:
  58 ===if===
  59  (if EXPR THEN_FUNCTION ELSE_FUNCTION_BODY...) -> LAST VALUE
  60
  61 */
  62 //#AFUNC        if      ml_if
  63 //#WIKIFUNC     if
  64 MNode*  ml_if (MNode* cell, MlEnv* mlenv) {
  65     MNode*  arg = cell->cdr ();
  66     MNodePtr  ans;
  67     bool  r;
  68
  69     if (arg) {
  70         r = eval_bool (arg->car (), mlenv);
  71         if (mlenv->breaksym ())
  72             return mlenv->breakval ();
  73         nextNode (arg);
  74         if (r) {
  75             if (arg) {
  76                 ans = eval (arg->car (), mlenv);
  77             }
  78         } else {
  79             nextNode (arg);
  80             if (arg) {
  81                 ans = progn (arg, mlenv);
  82 // ifはbreakの対象でない         mlenv->stopBreak (cell->car ());
  83             }
  84         }
  85     }
  86     return ans.release ();
  87 }
  88
  89 /*DOC:
  90 ===cond===
  91  (cond (EXPR BODY...)...) -> LAST VALUE
  92
  93 */
  94 //#AFUNC        cond    ml_cond
  95 //#WIKIFUNC     cond
  96 MNode*  ml_cond (MNode* cell, MlEnv* mlenv) {
  97     MNode*  arg = cell->cdr ();
  98     MNodePtr  ans;
  99     MNode*  a;
 100     bool  f;
 101
 102     while (arg && ! mlenv->breaksym ()) {
 103         a = arg->car ();
 104         if (a == NULL)
 105             throw (uNil + uErrorBadType);
 106         if (! a->isCons ())
 107             throw (a->dump_string () + uErrorBadType);
 108         f = eval_bool (a->car (), mlenv);
 109         if (mlenv->breaksym ()) {
 110             ans = mlenv->breakval ();
 111 // condはbreakの対象ではない        mlenv->stopBreak (cell->car ());
 112             break;
 113         }
 114         if (f) {
 115             ans = progn (a->cdr (), mlenv);
 116 // condはbreakの対象ではない        mlenv->stopBreak (cell->car ());
 117             break;
 118         }
 119         nextNode (arg);
 120     }
 121
 122     return ans.release ();
 123 }
 124
 125 /*DOC:
 126 ===progn===
 127  (progn [:on-error FUNCTION] BODY...) -> LAST VALUE
 128
 129 */
 130 //#AFUNC        progn   ml_progn
 131 //#WIKIFUNC     progn
 132 MNode*  ml_progn (MNode* cell, MlEnv* mlenv) {
 133     MNode*  arg = cell->cdr ();
 134     MNodePtr  ans;
 135     MNodePtr  errfn;
 136     std::vector<MNode*>  keywords;
 137     MNode*  rest;
 138     static paramList  kwlist[] = {
 139         {CharConst ("on-error"), false},
 140         {NULL, 0, 0}
 141     };
 142
 143     setParams (arg, 0, NULL, kwlist, &keywords, &rest);
 144     if (keywords[0])
 145         errfn = eval (keywords[0], mlenv);
 146
 147     try {
 148         ans =  progn (rest, mlenv);
 149     } catch (ustring& msg) {
 150         if (errfn ()) {
 151             onErrorFn (errfn (), mlenv);
 152         } else {
 153             throw (msg);
 154         }
 155     }
 156     mlenv->stopBreak (cell->car ());
 157
 158     return ans.release ();
 159 }
 160
 161 /*DOC:
 162 ===select, case, otherwise===
 163  (select
 164         (case BOOL1 BLOCK1)
 165         (case BOOL2 BLOCK2)
 166         ...
 167         (otherwise BLOCKn))
 168 */
 169 //#AFUNC        select  ml_select
 170 //#WIKIFUNC     select
 171 //#AFUNC        case    ml_case
 172 //#WIKIFUNC     case
 173 //#AFUNC        otherwise       ml_otherwise
 174 //#WIKIFUNC     otherwise
 175 MNode*  ml_select (MNode* cell, MlEnv* mlenv) {
 176     MNode*  arg = cell->cdr ();
 177     MNodePtr  ans;
 178
 179     while (arg && ! mlenv->breaksym ()) {
 180         ans = eval (arg->car (), mlenv);
 181         if (mlenv->breaksym ()) {
 182             ans = mlenv->breakval ();
 183 // 対象外        mlenv->stopBreak (cell->car ());
 184             return ans.release ();
 185         }
 186         nextNode (arg);
 187         if (ans ()) {
 188             if (ans ()->isCons () && to_bool (ans ()->car ())) {
 189                 ans = ans ()->cdr ();
 190                 return ans.release ();
 191             }
 192         } else {
 193             return NULL;
 194         }
 195     }
 196     return NULL;
 197 }
 198
 199 MNode*  ml_case (MNode* cell, MlEnv* mlenv) {
 200     MNode*  arg = cell->cdr ();
 201     MNodePtr  ans;
 202     bool  r;
 203
 204     if (! arg)
 205         throw (uErrorWrongNumber);
 206
 207     r = eval_bool (arg->car (), mlenv);
 208     nextNode (arg);
 209     ans = new MNode;
 210     if (r) {
 211         ans ()->set_car (newMNode_bool (true));
 212         ans ()->set_cdr (progn (arg, mlenv));
 213 //      mlenv->stopBreak (cell->car ());
 214     }
 215
 216     return ans.release ();
 217 }
 218
 219 MNode*  ml_otherwise (MNode* cell, MlEnv* mlenv) {
 220     MNode*  arg = cell->cdr ();
 221     MNodePtr  ans;
 222
 223     ans = new MNode;
 224     ans ()->set_car (newMNode_bool (true));
 225     ans ()->set_cdr (progn (arg, mlenv));
 226 //    mlenv->stopBreak (cell->car ());
 227
 228     return ans.release ();
 229 }
 230
 231 /*DOC:
 232 ===repeat===
 233  (repeat VARIABLE FROM TO [:step ADD] [:array VARLIST] BODY...) -> LAST VALUE
 234
 235 index VARIABLE is set local.
 236
 237 */
 238 //#AFUNC        repeat  ml_repeat
 239 MNode*  ml_repeat (MNode* cell, MlEnv* mlenv) {
 240     MNode*  arg = cell->cdr ();
 241     ustring  iv;
 242     double  from;
 243     double  to;
 244     double  step = 1.;
 245     std::vector<ustring>  lv;
 246     double  i;
 247     MNodePtr  ans;
 248     int  j;
 249     bool  kp;
 250     MNodePtr  t;
 251     std::vector<MNode*>  params;
 252     std::vector<MNode*>  keywords;
 253     MNode*  rest;
 254     static paramList  kwlist[] = {
 255         {CharConst ("step"), false},
 256         {CharConst ("array"), false},
 257         {NULL, 0, 0}
 258     };
 259
 260     setParams (arg, 3, &params, kwlist, &keywords, &rest);
 261     iv = eval_str (params[0], mlenv);
 262     from = eval_double (params[1], mlenv);
 263     to = eval_double (params[2], mlenv);
 264     if (keywords[0])
 265         step = eval_double (keywords[0], mlenv);
 266     if (evkw (1, t)) {
 267         MNode*  a;
 268         a = t ();
 269         if (a && a->isSym ()) {
 270             lv.push_back (a->to_string ());
 271         } else if (a && a->isCons ()) {
 272             while (a) {
 273                 lv.push_back (to_string (a->car ()));
 274                 nextNode (a);
 275             }
 276         } else {
 277             throw (to_string (t ()) + ustring (": bad argument."));
 278         }
 279     }
 280
 281     {
 282         AutoLocalVariable  autoLocal (mlenv);
 283
 284         mlenv->defineLocalVar (iv);
 285
 286         if (step > 0) {
 287             kp = true;
 288             for (i = from; kp && i <= to; i += step) {
 289                 t = newMNode_num (i);
 290                 mlenv->setVar (iv, t ());
 291                 if (i > 0)
 292                     for (j = 0; j < lv.size (); j ++)
 293                         mlenv->setVar (lv[j], mlenv->getAry (lv[j], (size_t)i));
 294                 ans = progn (rest, mlenv);
 295                 if (mlenv->breaksym ()) {
 296                     mlenv->stopBreak (cell->car ());
 297                     kp = false;
 298                 }
 299                 if (i > 0)
 300                     for (j = 0; j < lv.size (); j ++)
 301                         mlenv->setAry (lv[j], (size_t)i, mlenv->getVar (lv[j]));
 302 #if 0
 303                 if (mlenv->qtimeup ())
 304                     break;
 305 #endif
 306             }
 307         } else if (step < 0) {
 308             kp = true;
 309             for (i = from; kp && i >= to; i += step) {
 310                 t = newMNode_num (i);
 311                 mlenv->setVar (iv, t ());
 312                 if (i > 0)
 313                     for (j = 0; j < lv.size (); j ++)
 314                         mlenv->setVar (lv[j], mlenv->getAry (lv[j], (size_t)i));
 315                 ans = progn (rest, mlenv);
 316                 if (mlenv->breaksym ()) {
 317                     mlenv->stopBreak (cell->car ());
 318                     kp = false;
 319                 }
 320                 if (i > 0)
 321                     for (j = 0; j < lv.size (); j ++)
 322                         mlenv->setAry (lv[j], (size_t)i, mlenv->getVar (lv[j]));
 323 #if 0
 324                 if (mlenv->qtimeup ())
 325                     break;
 326 #endif
 327             }
 328         }
 329     }
 330
 331     return mlenv->retval = ans ();
 332 }
 333
 334 /*DOC:
 335 ===doarray===
 336  (doarray '(ARRAY_VARIABLE ...) [:index VARIABLE] [:setvar '(VARIABLE...)] BODY...) -> LAST VALUE
 337
 338 index VARIABLE is set local.
 339
 340 */
 341 //#AFUNC        doarray ml_doarray
 342 //#WIKIFUNC     doarray
 343 MNode*  ml_doarray (MNode* cell, MlEnv* mlenv) {
 344     MNode*  arg = cell->cdr ();
 345     std::vector<ustring>  lv;
 346     std::vector<ustring>  setvar;
 347     ustring  iv;
 348     size_t  i, n;
 349     int  it, nlv, nsv;
 350     ustring  val;
 351     MNodePtr  ans;
 352     MNodePtr  t;
 353     bool  kp;
 354     std::vector<MNode*>  params;
 355     std::vector<MNode*>  keywords;
 356     MNode*  rest;
 357     static paramList  kwlist[] = {
 358         {CharConst ("index"), false},
 359         {CharConst ("setvar"), false},
 360         {NULL, 0, 0}
 361     };
 362
 363     setParams (arg, 1, &params, kwlist, &keywords, &rest);
 364     t = eval (params[0], mlenv);
 365     if (t () && t ()->isSym ()) {
 366         lv.push_back (t ()->to_string ());
 367     } else if (t () && t ()->isCons ()) {
 368         MNode*  a = t ();
 369         while (a && a->isCons ()) {
 370             lv.push_back (to_string (a->car ()));
 371             nextNode (a);
 372         }
 373     } else {
 374         throw (dump_to_sexp (t ()) + ustring (": bad argument."));
 375     }
 376     if (evkw (0, t))
 377         iv = to_string (t ());
 378     if (evkw (1, t)) {
 379         if (t () && t ()->isSym ()) {
 380             setvar.push_back (to_string (t ()));
 381         } else if (t () && t ()->isCons ()) {
 382             MNode*  a = t ();
 383             while (a && a->isCons ()) {
 384                 setvar.push_back (to_string (a->car ()));
 385                 nextNode (a);
 386             }
 387         } else {
 388             throw (ustring (CharConst (":setvar ")) + dump_to_sexp (t ()) + ustring (": bad argument."));
 389         }
 390     }
 391
 392     {
 393         AutoLocalVariable  autoLocal (mlenv);
 394
 395         if (iv.length () > 0)
 396             mlenv->defineLocalVar (iv);
 397
 398         nlv = lv.size ();
 399         nsv = setvar.size ();
 400         if (nsv > 0 && nlv > nsv)
 401             nlv = nsv;
 402
 403         if (nlv > 0) {
 404             kp = true;
 405             n = mlenv->getArySize (lv[0]);
 406             for (i = 1; kp && i <= n; i ++) {
 407                 if (nsv == 0) {
 408                     for (it = 0; it < nlv; it ++) {
 409                         mlenv->setVar (lv[it], mlenv->getAry (lv[it], i));
 410                     }
 411                 } else {
 412                     for (it = 0; it < nlv; it ++) {
 413                         mlenv->setVar (setvar[it], mlenv->getAry (lv[it], i));
 414                     }
 415                     for (; it < nsv; it ++) {
 416                         mlenv->setVar (setvar[it], NULL);
 417                     }
 418                 }
 419                 if (iv.size () > 0) {
 420                     t = newMNode_num (i);
 421                     mlenv->setVar (iv, t ());
 422                 }
 423                 ans = progn (rest, mlenv);
 424                 if (mlenv->breaksym ()) {
 425                     mlenv->stopBreak (cell->car ());
 426                     kp = false;
 427                 }
 428                 if (nsv == 0) {
 429                     for (it = 0; it < nlv; it ++) {
 430                         mlenv->setAry (lv[it], i, mlenv->getVar (lv[it]));
 431                     }
 432                 } else {
 433                     for (it = 0; it < nlv; it ++) {
 434                         mlenv->setAry (lv[it], i, mlenv->getVar (setvar[it]));
 435                     }
 436                 }
 437             }
 438             for (it = 0; it < nlv; it ++) {
 439                 mlenv->setArySize (lv[it], n);
 440             }
 441         }
 442     }
 443
 444     return ans.release ();
 445 }
 446
 447 /*DOC:
 448 //===dolist===
 449 ===list-each===
 450 // (dolist '(VARIABLE1...) '(LIST...) [:index VARIABLE2] BODY...) -> LAST VALUE
 451  (list-each '(VARIABLE1...) '(LIST...) [:index VARIABLE2] BODY...) -> LAST VALUE
 452
 453 list VARIABLE1 and index VARIABLE2 is set local.
 454
 455 */
 456 //#AFUNC        dolist  ml_list_each
 457 //#AFUNC        list-each       ml_list_each
 458 //#WIKIFUNC     dolist
 459 //#WIKIFUNC     list-each
 460 MNode*  ml_list_each (MNode* cell, MlEnv* mlenv) {
 461     MNode*  arg = cell->cdr ();
 462     std::vector<ustring>  lv;
 463     int  it, iu;
 464     MNodePtr  vlist;
 465     MNodePtr  list;
 466     ustring  iv;
 467     std::vector<MNode*>  llv;
 468     MNode*  a;
 469     MNodePtr  ans;
 470     MNodePtr  h;
 471     int  i;
 472     bool  kp;
 473     std::vector<MNode*>  params;
 474     std::vector<MNode*>  keywords;
 475     MNode*  rest;
 476     static paramList  kwlist[] = {
 477         {CharConst ("index"), false},
 478         {NULL, 0, 0}
 479     };
 480
 481     setParams (arg, 2, &params, kwlist, &keywords, &rest);
 482     vlist = eval (params[0], mlenv);
 483     if (vlist () && vlist ()->isSym ()) {
 484         lv.push_back (vlist ()->to_string ());
 485     } else if (vlist () && vlist ()->isCons ()) {
 486         a = vlist ();
 487         while (a && a->isCons ()) {
 488             lv.push_back (to_string (a->car ()));
 489             nextNode (a);
 490         }
 491     } else {
 492         throw (to_string (vlist ()) + ustring (": bad argument."));
 493     }
 494     list = eval (params[1], mlenv);
 495     if (keywords[0])
 496         iv = eval_str (keywords[0], mlenv);
 497
 498     a = list ();
 499     iu = lv.size ();
 500     for (i = 0; i < iu; i ++) {
 501         if (a)
 502             llv.push_back (a->car ());
 503         else
 504             llv.push_back (NULL);
 505         nextNode (a);
 506     }
 507
 508     {
 509         AutoLocalVariable  autoLocal (mlenv);
 510
 511         for (it = 0; it < iu; it ++)
 512             mlenv->defineLocalVar (lv[it]);
 513         if (iv.length () > 0)
 514             mlenv->defineLocalVar (iv);
 515
 516         if (iu > 0 && llv.size () > 0) {
 517             kp = true;
 518             for (i = 1; kp && llv[0]; i ++) {
 519                 if (iv.length () > 0) {
 520                     mlenv->setVar (iv, newMNode_num (i));
 521                 }
 522                 for (it = 0; it < iu; it ++) {
 523                     if (llv[it])
 524                         mlenv->setVar (lv[it], llv[it]->car ());
 525                     else
 526                         mlenv->setVar (lv[it], NULL);
 527                     nextNode (llv[it]);
 528                 }
 529                 ans = progn (rest, mlenv);
 530                 if (mlenv->breaksym ()) {
 531                     mlenv->stopBreak (cell->car ());
 532                     kp = false;
 533                 }
 534             }
 535         }
 536     }
 537
 538     return ans.release ();
 539 }
 540
 541 /*DOC:
 542 ===while===
 543  (while EXPR BODY...) -> LAST VALUE
 544
 545 */
 546 //#AFUNC        while   ml_while
 547 MNode*  ml_while (MNode* cell, MlEnv* mlenv) {
 548     MNode*  arg = cell->cdr ();
 549     MNodePtr  ans;
 550     MNode*  exp;
 551
 552     if (arg) {
 553         exp = arg->car ();
 554         nextNode (arg);
 555         while (eval_bool (exp, mlenv)) {
 556             ans = progn (arg, mlenv);
 557             if (mlenv->breaksym ()) {
 558                 mlenv->stopBreak (cell->car ());
 559                 break;
 560             }
 561         }
 562     }
 563     return ans.release ();
 564 }
 565
 566 /*DOC:
 567 ===break===
 568  (break FUNCTION-NAME VALUE) -> NULL
 569
 570 */
 571 //#AFUNC        break   ml_break
 572 MNode*  ml_break (MNode* cell, MlEnv* mlenv) {
 573     MNode*  arg = cell->cdr ();
 574     MNodePtr  sym;
 575     MNodePtr  val;
 576
 577     if (!arg) {
 578         sym = new MNode;
 579     } else {
 580         sym = eval (arg->car (), mlenv);
 581         nextNode (arg);
 582         if (arg) {
 583             val = eval (arg->car (), mlenv);
 584             nextNode (arg);
 585             if (arg)
 586                 throw (uErrorWrongNumber);
 587         }
 588     }
 589     mlenv->setBreak (sym.release (), val ());
 590
 591     return mlenv->retval = val.release ();
 592 }
 593
 594 /*DOC:
 595 ===exit===
 596  (exit) -> NULL
 597
 598 */
 599 //#AFUNC        exit    ml_exit
 600 MNode*  ml_exit (MNode* cell, MlEnv* mlenv) {
 601     MNode*  arg = cell->cdr ();
 602
 603     if (arg)
 604         throw (uErrorWrongNumber);
 605
 606     mlenv->breakProg ();
 607
 608     return NULL;
 609 }
 610
 611 /*DOC:
 612 ===apply===
 613  (apply FUNCTION-NAME VALUE... LIST) -> ANY
 614  (apply LAMBDA VALUE... LIST) -> ANY
 615
 616 */
 617 //#AFUNC        apply   ml_apply
 618 MNode*  ml_apply (MNode* cell, MlEnv* mlenv) {
 619     MNode*  arg = cell->cdr ();
 620     MNodePtr  fn;
 621     MNodeList  list;
 622     MNodePtr  h;
 623
 624     if (! arg)
 625         throw (uErrorWrongNumber);
 626     fn = eval (arg->car (), mlenv);
 627     nextNode (arg);
 628     if (! fn ()) {
 629         throw (uErrorSyntax);
 630     } else if (isLambda (fn ())) {
 631         while (arg) {
 632             if (! isNil (arg->cdr ())) {
 633                 list.append (eval (arg->car (), mlenv));
 634             } else {
 635                 MNode*  a;
 636                 h = eval (arg->car (), mlenv);
 637                 a = h ();
 638                 while (a && a->isCons ()) {
 639                     list.append (a->car ());
 640                     nextNode (a);
 641                 }
 642             }
 643             nextNode (arg);
 644         }
 645         return mlenv->retval = execDefun (mlenv, fn (), list (), uEmpty);
 646     } else if (fn ()->isSym ()) {
 647         while (arg) {
 648             if (! isNil (arg->cdr ())) {
 649                 list.append (quoted (eval (arg->car (), mlenv)));
 650             } else {
 651                 MNode*  a;
 652                 h = eval (arg->car (), mlenv);
 653                 a = h ();
 654                 while (a && a->isCons ()) {
 655                     list.append (quoted (a->car ()));
 656                     nextNode (a);
 657                 }
 658             }
 659             nextNode (arg);
 660         }
 661
 662         MNodePtr  f;
 663         f = new MNode ();
 664         f ()->set_car (fn ());
 665         f ()->set_cdr (list ());
 666         return mlenv->retval = eval (f (), mlenv);
 667     } else {
 668         throw (uErrorSyntax);
 669     }
 670     return NULL;
 671 }
 672
 673 /*DOC:
 674 ===funcall===
 675  (funcall LAMBDA PARAMS...)
 676
 677 */
 678 //#AFUNC        funcall ml_funcall
 679 MNode*  ml_funcall (MNode* cell, MlEnv* mlenv) {
 680     MNode*  arg = cell->cdr ();
 681     MNodePtr  fn;
 682
 683     if (! arg)
 684         throw (uErrorWrongNumber);
 685     fn = eval (arg->car (), mlenv);
 686     nextNode (arg);
 687
 688     if (! fn ()) {
 689         throw (uErrorSyntax);
 690     } else if (isLambda (fn ())) {
 691         return mlenv->retval = execDefun (mlenv, fn (), arg, uEmpty);
 692     } else if (fn ()->isSym ()) {
 693         MNodePtr  f;
 694         f = new MNode ();
 695         f ()->set_car (fn ());
 696         f ()->set_cdr (arg);
 697         return mlenv->retval = eval (f (), mlenv);
 698     } else {
 699         throw (uErrorSyntax);
 700     }
 701     return NULL;
 702 }
 703
 704 /*DOC:
 705 ===eval===
 706  (eval ANY) -> ANY
 707
 708 */
 709 //#AFUNC        eval    ml_eval
 710 MNode*  ml_eval (MNode* cell, MlEnv* mlenv) {
 711     MNode*  arg = cell->cdr ();
 712     MNodePtr  h;
 713
 714     if (! arg)
 715         throw (uErrorWrongNumber);
 716     h = eval (arg->car (), mlenv);
 717     nextNode (arg);
 718     if (arg)
 719         throw (uErrorWrongNumber);
 720     return mlenv->retval = eval (h (), mlenv);
 721 }
 722
 723 /*DOC:
 724 ===car===
 725  (car LIST) -> LIST
 726
 727 */
 728 //#AFUNC        car     ml_car
 729 //#WIKIFUNC     car
 730 MNode*  ml_car (MNode* cell, MlEnv* mlenv) {
 731     MNode*  arg = cell->cdr ();
 732     MNodePtr  h;
 733
 734     if (! arg)
 735         throw (uErrorWrongNumber);
 736     h = eval (arg->car (), mlenv);
 737     nextNode (arg);
 738     if (arg)
 739         throw (uErrorWrongNumber);
 740
 741     if (h () && h ()->isCons ()) {
 742         return mlenv->retval = h ()->car ();
 743     } else {
 744         return NULL;
 745     }
 746 }
 747
 748 /*DOC:
 749 ===cdr===
 750  (cdr LIST) -> LIST
 751
 752 */
 753 //#AFUNC        cdr     ml_cdr
 754 //#WIKIFUNC     cdr
 755 MNode*  ml_cdr (MNode* cell, MlEnv* mlenv) {
 756     MNode*  arg = cell->cdr ();
 757     MNodePtr  h;
 758
 759     if (! arg)
 760         throw (uErrorWrongNumber);
 761     h = eval (arg->car (), mlenv);
 762     nextNode (arg);
 763     if (arg)
 764         throw (uErrorWrongNumber);
 765
 766     if (h () && h ()->isCons ()) {
 767         return mlenv->retval = h ()->cdr ();
 768     } else {
 769         return NULL;
 770     }
 771 }
 772
 773 /*DOC:
 774 ===nth===
 775  (nth N LIST) -> ELEMENT
 776 (car LIST) is (nth 0 LIST)
 777
 778 */
 779 //#AFUNC        nth     ml_nth
 780 //#WIKIFUNC     nth
 781 MNode*  ml_nth (MNode* cell, MlEnv* mlenv) {
 782     MNode*  arg = cell->cdr ();
 783     int  n;
 784     MNodePtr  h;
 785     MNode*  a;
 786
 787     if (! arg)
 788         throw (uErrorWrongNumber);
 789     n = eval_int (arg->car (), mlenv);
 790     nextNode (arg);
 791     h = eval (arg->car (), mlenv);
 792     nextNode (arg);
 793     if (arg)
 794         throw (uErrorWrongNumber);
 795
 796     a = h ();
 797     while (n > 0 && a && a->isCons ()) {
 798         n --;
 799         nextNode (a);
 800     }
 801
 802     if (a && a->isCons ())
 803         return mlenv->retval = a->car ();
 804     else
 805         return NULL;
 806 }
 807
 808
 809 /*DOC:
 810 ===replca===
 811  (replca CELL NEWCAR) -> NEWCAR
 812
 813 */
 814 //#AFUNC        replca  ml_replca
 815 MNode*  ml_replca (MNode* cell, MlEnv* mlenv) {
 816     MNode*  arg = cell->cdr ();
 817     MNodePtr  c;
 818     MNodePtr  newcar;
 819
 820     if (! arg)
 821         throw (uErrorWrongNumber);
 822     c = eval (arg->car (), mlenv);
 823     nextNodeNonNil (arg);
 824     newcar = eval (arg->car (), mlenv);
 825     nextNode (arg);
 826     if (arg)
 827         throw (uErrorWrongNumber);
 828
 829     if (! c ())
 830         throw (ustring (CharConst ("nil data.")));
 831     if (! c ()->isCons ())
 832         throw (c ()->dump_string () + uErrorBadType);
 833     c ()->unset_car ();
 834     c ()->set_car (newcar ());
 835
 836     return mlenv->retval = newcar ();
 837 }
 838
 839 /*DOC:
 840 ===replcd===
 841  (replcd CELL NEWCDR) -> NEWCDR
 842
 843 */
 844 //#AFUNC        replcd  ml_replcd
 845 MNode*  ml_replcd (MNode* cell, MlEnv* mlenv) {
 846     MNode*  arg = cell->cdr ();
 847     MNodePtr  c;
 848     MNodePtr  newcdr;
 849
 850     if (! arg)
 851         throw (uErrorWrongNumber);
 852     c = eval (arg->car (), mlenv);
 853     nextNodeNonNil (arg);
 854     newcdr = eval (arg->car (), mlenv);
 855     nextNode (arg);
 856     if (arg)
 857         throw (uErrorWrongNumber);
 858
 859     if (! c ())
 860         throw (ustring (CharConst ("nil data.")));
 861     if (! c ()->isCons ())
 862         throw (c ()->dump_string () + uErrorBadType);
 863     c ()->unset_cdr ();
 864     c ()->set_cdr (newcdr ());
 865
 866     return mlenv->retval = newcdr ();
 867 }
 868
 869 /*DOC:
 870 ===cons===
 871  (cons CAR CDR) -> CONS
 872
 873 */
 874 //#AFUNC        cons    ml_cons
 875 //#WIKIFUNC     cons
 876 MNode*  ml_cons (MNode* cell, MlEnv* mlenv) {
 877     MNode*  arg = cell->cdr ();
 878     MNodePtr  car;
 879     MNodePtr  cdr;
 880     MNodePtr  ans;
 881
 882     if (! arg)
 883         throw (uErrorWrongNumber);
 884     car = eval (arg->car (), mlenv);
 885     nextNode (arg);
 886     if (arg) {
 887         cdr = eval (arg->car (), mlenv);
 888         nextNode (arg);
 889     }
 890     if (arg)
 891         throw (uErrorWrongNumber);
 892
 893     ans = new MNode;
 894     ans ()->set_car (car ());
 895     ans ()->set_cdr (cdr ());
 896
 897     return mlenv->retval = ans ();
 898 }
 899
 900 /*DOC:
 901 ===append===
 902  (append LIST...) -> LIST
 903
 904 */
 905 //#AFUNC        append  ml_append
 906 //#WIKIFUNC     append
 907 MNode*  ml_append (MNode* cell, MlEnv* mlenv) {
 908     MNode*  arg = cell->cdr ();
 909     MNodePtr  h;
 910     MNodeList  list;
 911     MNode*  a;
 912
 913     while (arg) {
 914         h = eval (arg->car (), mlenv);
 915         nextNode (arg);
 916         if (arg) {
 917             a = h ();
 918             while (a && a->isCons ()) {
 919                 list.append (a->car ());
 920                 nextNode (a);
 921             }
 922         } else {
 923             list.set_cdr_cut (h ());
 924         }
 925     }
 926
 927     return mlenv->retval = list ();
 928 }
 929
 930 /*DOC:
 931 ===mapcar===
 932  (mapcar LAMBDA LIST...) -> LIST
 933
 934 */
 935 //#AFUNC        mapcar  ml_mapcar
 936 //#WIKIFUNC     mapcar
 937 MNode*  ml_mapcar (MNode* cell, MlEnv* mlenv) {
 938     MNode*  arg = cell->cdr ();
 939     MNodePtr  fn;
 940     MNodeList  list;
 941     MNodeList  ans;
 942     MNodePtr  h;
 943     bool  f;
 944
 945     if (! arg)
 946         throw (uErrorWrongNumber);
 947     fn = eval (arg->car (), mlenv);
 948     nextNodeNonNil (arg);
 949     while (arg) {
 950         list.append (eval (arg->car (), mlenv));
 951         nextNode (arg);
 952     }
 953
 954     if (! fn ()) {
 955         throw (uErrorSyntax);
 956     } else if (isLambda (fn ())) {
 957     } else if (fn ()->isSym ()) {
 958     } else {
 959         throw (uErrorSyntax);
 960     }
 961     if (isNil (list ()))
 962         return NULL;
 963
 964     if (fn ()->isSym ()) {
 965         while (1) {
 966             MNodeList  e;
 967             arg = list ();
 968             f = false;
 969             while (arg) {
 970                 h = arg->car ();
 971                 if (h () && h ()->isCons ()) {
 972                     e.append (newMNode_quote (h ()->car ()));
 973                     arg->unset_car ();
 974                     arg->set_car (h ()->cdr ());
 975                     f = true;
 976                 } else {
 977                     e.append (NULL);
 978                 }
 979                 nextNode (arg);
 980             }
 981             if (! f)
 982                 break;
 983             h = new MNode ();
 984             h ()->set_car (fn ());
 985             h ()->set_cdr (e.release ());
 986             ans.append (eval (h (), mlenv));
 987         }
 988     } else {
 989         while (1) {
 990             MNodeList  e;
 991             arg = list ();
 992             f = false;
 993             while (arg) {
 994                 h = arg->car ();
 995                 if (h () && h ()->isCons ()) {
 996                     e.append (h ()->car ());
 997                     arg->unset_car ();
 998                     arg->set_car (h ()->cdr ());
 999                     f = true;
1000                 } else {
1001                     e.append (NULL);
1002                 }
1003                 nextNode (arg);
1004             }
1005             if (! f)
1006                 break;
1007             ans.append (execDefun (mlenv, fn (), e (), uEmpty));
1008         }
1009     }
1010
1011     return ans.release ();
1012 }
1013
1014 /*DOC:
1015 ===mapcar-collect===
1016  (mapcar-collect LAMBDA LIST...) -> LIST
1017
1018 */
1019 //#AFUNC        mapcar-collect  ml_mapcar_collect
1020 //#WIKIFUNC     mapcar-collect
1021 MNode*  ml_mapcar_collect (MNode* cell, MlEnv* mlenv) {
1022     MNode*  arg = cell->cdr ();
1023     MNodePtr  fn;
1024     MNodeList  list;
1025     MNodeList  ans;
1026     MNodePtr  h;
1027     MNodePtr  v;
1028     bool  f;
1029
1030     if (! arg)
1031         throw (uErrorWrongNumber);
1032     fn = eval (arg->car (), mlenv);
1033     nextNodeNonNil (arg);
1034     while (arg) {
1035         list.append (eval (arg->car (), mlenv));
1036         nextNode (arg);
1037     }
1038
1039     if (! fn ()) {
1040         throw (uErrorSyntax);
1041     } else if (isLambda (fn ())) {
1042     } else if (fn ()->isSym ()) {
1043     } else {
1044         throw (uErrorSyntax);
1045     }
1046     if (isNil (list ()))
1047         return NULL;
1048
1049     if (fn ()->isSym ()) {
1050         while (1) {
1051             MNodeList  e;
1052             arg = list ();
1053             f = false;
1054             while (arg) {
1055                 h = arg->car ();
1056                 if (h () && h ()->isCons ()) {
1057                     e.append (newMNode_quote (h ()->car ()));
1058                     arg->unset_car ();
1059                     arg->set_car (h ()->cdr ());
1060                     f = true;
1061                 } else {
1062                     e.append (NULL);
1063                 }
1064                 nextNode (arg);
1065             }
1066             if (! f)
1067                 break;
1068             h = new MNode ();
1069             h ()->set_car (fn ());
1070             h ()->set_cdr (e.release ());
1071             v = eval (h (), mlenv);
1072             if (v ())
1073                 ans.append (v.release ());
1074         }
1075     } else {
1076         while (1) {
1077             MNodeList  e;
1078             arg = list ();
1079             f = false;
1080             while (arg) {
1081                 h = arg->car ();
1082                 if (h () && h ()->isCons ()) {
1083                     e.append (h ()->car ());
1084                     arg->unset_car ();
1085                     arg->set_car (h ()->cdr ());
1086                     f = true;
1087                 } else {
1088                     e.append (NULL);
1089                 }
1090                 nextNode (arg);
1091             }
1092             if (! f)
1093                 break;
1094             v = execDefun (mlenv, fn (), e (), uEmpty);
1095             if (v ())
1096                 ans.append (v.release ());
1097         }
1098     }
1099
1100     return ans.release ();
1101 }
1102
1103 /*DOC:
1104 ===mapcar-append===
1105  (mapcar-append LAMBDA LIST...) -> LIST
1106
1107 */
1108 //#AFUNC        mapcar-append   ml_mapcar_append
1109 //#WIKIFUNC     mapcar-append
1110 MNode*  ml_mapcar_append (MNode* cell, MlEnv* mlenv) {
1111     MNode*  arg = cell->cdr ();
1112     MNodePtr  fn;
1113     MNodeList  list;
1114     MNodeList  ans;
1115     MNodePtr  h;
1116     MNodePtr  v;
1117     bool  f;
1118
1119     if (! arg)
1120         throw (uErrorWrongNumber);
1121     fn = eval (arg->car (), mlenv);
1122     nextNodeNonNil (arg);
1123     while (arg) {
1124         list.append (eval (arg->car (), mlenv));
1125         nextNode (arg);
1126     }
1127
1128     if (! fn ()) {
1129         throw (uErrorSyntax);
1130     } else if (isLambda (fn ())) {
1131     } else if (fn ()->isSym ()) {
1132     } else {
1133         throw (uErrorSyntax);
1134     }
1135     if (isNil (list ()))
1136         return NULL;
1137
1138     if (fn ()->isSym ()) {
1139         while (1) {
1140             MNodeList  e;
1141             arg = list ();
1142             f = false;
1143             while (arg) {
1144                 h = arg->car ();
1145                 if (h () && h ()->isCons ()) {
1146                     e.append (newMNode_quote (h ()->car ()));
1147                     arg->unset_car ();
1148                     arg->set_car (h ()->cdr ());
1149                     f = true;
1150                 } else {
1151                     e.append (NULL);
1152                 }
1153                 nextNode (arg);
1154             }
1155             if (! f)
1156                 break;
1157             h = new MNode ();
1158             h ()->set_car (fn ());
1159             h ()->set_cdr (e.release ());
1160             v = eval (h (), mlenv);
1161             if (! v ()) {
1162             } else if (v ()->isCons ()) {
1163                 MNode*  a = v ();
1164                 while (a) {
1165                     ans.append (a->car ());
1166                     nextNode (a);
1167                 }
1168             } else {
1169                 ans.append (v.release ());      // XXX: hack
1170             }
1171         }
1172     } else {
1173         while (1) {
1174             MNodeList  e;
1175             arg = list ();
1176             f = false;
1177             while (arg) {
1178                 h = arg->car ();
1179                 if (h () && h ()->isCons ()) {
1180                     e.append (h ()->car ());
1181                     arg->unset_car ();
1182                     arg->set_car (h ()->cdr ());
1183                     f = true;
1184                 } else {
1185                     e.append (NULL);
1186                 }
1187                 nextNode (arg);
1188             }
1189             if (! f)
1190                 break;
1191             v = execDefun (mlenv, fn (), e (), uEmpty);
1192             if (! v ()) {
1193             } else if (v ()->isCons ()) {
1194                 MNode*  a = v ();
1195                 while (a) {
1196                     ans.append (a->car ());
1197                     nextNode (a);
1198                 }
1199             } else {
1200                 ans.append (v.release ());      // XXX: hack
1201             }
1202         }
1203     }
1204
1205     return ans.release ();
1206 }
1207
1208 /*DOC:
1209 ===mapcar-concat===
1210  (mapcar-concat LAMBDA LIST...) -> LIST
1211
1212 */
1213 //#AFUNC        mapcar-concat   ml_mapcar_concat
1214 //#WIKIFUNC     mapcar-concat
1215 MNode*  ml_mapcar_concat (MNode* cell, MlEnv* mlenv) {
1216     MNode*  arg = cell->cdr ();
1217     MNodePtr  fn;
1218     MNodeList  list;
1219     MNodeList  ans;
1220     MNodePtr  h;
1221     MNodePtr  v;
1222     bool  f;
1223
1224     if (! arg)
1225         throw (uErrorWrongNumber);
1226     fn = eval (arg->car (), mlenv);
1227     nextNodeNonNil (arg);
1228     while (arg) {
1229         list.append (eval (arg->car (), mlenv));
1230         nextNode (arg);
1231     }
1232
1233     if (! fn ()) {
1234         throw (uErrorSyntax);
1235     } else if (isLambda (fn ())) {
1236     } else if (fn ()->isSym ()) {
1237     } else {
1238         throw (uErrorSyntax);
1239     }
1240     if (isNil (list ()))
1241         return NULL;
1242
1243     if (fn ()->isSym ()) {
1244         while (1) {
1245             MNodeList  e;
1246             arg = list ();
1247             f = false;
1248             while (arg) {
1249                 h = arg->car ();
1250                 if (h () && h ()->isCons ()) {
1251                     e.append (newMNode_quote (h ()->car ()));
1252                     arg->unset_car ();
1253                     arg->set_car (h ()->cdr ());
1254                     f = true;
1255                 } else {
1256                     e.append (NULL);
1257                 }
1258                 nextNode (arg);
1259             }
1260             if (! f)
1261                 break;
1262             h = new MNode ();
1263             h ()->set_car (fn ());
1264             h ()->set_cdr (e.release ());
1265             v = eval (h (), mlenv);
1266             if (! v ()) {
1267             } else {
1268                 ans.append (v.release ());
1269             }
1270         }
1271     } else {
1272         while (1) {
1273             MNodeList  e;
1274             arg = list ();
1275             f = false;
1276             while (arg) {
1277                 h = arg->car ();
1278                 if (h () && h ()->isCons ()) {
1279                     e.append (h ()->car ());
1280                     arg->unset_car ();
1281                     arg->set_car (h ()->cdr ());
1282                     f = true;
1283                 } else {
1284                     e.append (NULL);
1285                 }
1286                 nextNode (arg);
1287             }
1288             if (! f)
1289                 break;
1290             v = execDefun (mlenv, fn (), e (), uEmpty);
1291             if (! v ()) {
1292             } else {
1293                 ans.append (v.release ());
1294             }
1295         }
1296     }
1297
1298     return ans.release ();
1299 }
1300
1301 /*DOC:
1302 ===member===
1303  (member ELT LIST) -> LIST
1304
1305 Return 1 if LIST contaions ELT. The comparison is done by ===.
1306
1307 */
1308 //#AFUNC        member  ml_member
1309 //#WIKIFUNC     member
1310 MNode*  ml_member (MNode* cell, MlEnv* mlenv) {
1311     MNode*  arg = cell->cdr ();
1312     MNodePtr  elt;
1313     MNodePtr  list;
1314
1315     if (! arg)
1316         throw (uErrorWrongNumber);
1317     elt = eval (arg->car (), mlenv);
1318     nextNode (arg);
1319     list = eval (arg->car (), mlenv);
1320     nextNode (arg);
1321     if (arg)
1322         throw (uErrorWrongNumber);
1323
1324     arg = list ();
1325     while (arg) {
1326         if (eq (elt (), arg->car ())) {
1327             return newMNode_bool (true);
1328         }
1329         nextNode (arg);
1330     }
1331     return NULL;
1332 }
1333
1334 /*DOC:
1335 ===memberp===
1336  (memberp LAMBDA LIST) -> LIST
1337
1338 Return first cdr of LIST that the LAMBDA applied the element returns true.
1339
1340 */
1341 //#AFUNC        memberp ml_memberp
1342 //#WIKIFUNC     memberp
1343 MNode*  ml_memberp (MNode* cell, MlEnv* mlenv) {
1344     MNode*  arg = cell->cdr ();
1345     MNodePtr  fn;
1346     MNodePtr  list;
1347
1348     if (! arg)
1349         throw (uErrorWrongNumber);
1350     fn = eval (arg->car (), mlenv);
1351     nextNode (arg);
1352     list = eval (arg->car (), mlenv);
1353     nextNode (arg);
1354     if (arg)
1355         throw (uErrorWrongNumber);
1356
1357     if (! fn ()) {
1358         throw (uErrorSyntax);
1359     } else if (isLambda (fn ())) {
1360     } else if (fn ()->isSym ()) {
1361     } else {
1362         throw (uErrorSyntax);
1363     }
1364
1365     arg = list ();
1366     if (fn ()->isSym ()) {
1367         MNodePtr  sexp;
1368         sexp = new MNode ();
1369         sexp ()->set_car (fn ());
1370         MNode*  q = new MNode ();
1371         sexp ()->set_cdr (q);
1372         q->set_car (NULL);
1373         while (arg) {
1374             q->unset_car ();
1375             q->set_car (eval (arg->car (), mlenv));
1376             if (eval_bool (sexp (), mlenv))
1377                 return arg;
1378             nextNode (arg);
1379         }
1380     } else {
1381         MNodePtr  h;
1382         while (arg) {
1383             h = new MNode;
1384             h ()->set_car (arg->car ());
1385             h = execDefun (mlenv, fn (), h (), uEmpty);
1386             if (to_bool (h ()))
1387                 return arg;
1388             nextNode (arg);
1389         }
1390     }
1391     return NULL;
1392 }
1393
1394 /*DOC:
1395 ===reverse===
1396  (reverse LIST) -> LIST
1397
1398 */
1399 //#AFUNC        reverse ml_reverse
1400 //#WIKIFUNC     reverse
1401 MNode*  ml_reverse (MNode* cell, MlEnv* mlenv) {
1402     MNode*  arg = cell->cdr ();
1403     MNodePtr  a;
1404     MNodePtr  ans;
1405     MNode*  c;
1406
1407     if (! arg)
1408         throw (uErrorWrongNumber);
1409     a = eval (arg->car (), mlenv);
1410     nextNode (arg);
1411     if (arg)
1412         throw (uErrorWrongNumber);
1413
1414     if (! a () || ! a ()->isCons ()) {
1415         ans = a ();
1416     } else {
1417         while (a () && a ()->isCons ()) {
1418             c = new MNode;
1419             c->set_car (a ()->car ());
1420             c->set_cdr (ans ());
1421             ans = c;
1422             a = a ()->cdr ();
1423         }
1424     }
1425
1426     return mlenv->retval = ans.release ();
1427 }