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