lib/expr.cc

   1 #include "expr.h"
   2 #include "ml.h"
   3 #include "mlenv.h"
   4 #include "ftable.h"
   5 #include "motorvar.h"
   6 #include "util_const.h"
   7 #include "util_string.h"
   8 #include "util_check.h"
   9 #include "ustring.h"
  10 #include <boost/unordered_map.hpp>
  11 #include <iostream>
  12 #include <stdlib.h>
  13 #include <assert.h>
  14
  15 static MNode*  callFunc (MNode* cell, MlEnv* mlenv) {
  16     MNodePtr  ans;
  17     FTableVal*  t;
  18     MLFunc*  u;
  19     const ustring*  name = ptr_symbol (cell->car ());
  20     MNodePtr  bcell;
  21     MNode*  sexp;
  22
  23 #ifdef DEBUG
  24     if (! (name && *name == uQuote))
  25         mlenv->logSexp (cell);
  26 #endif /* DEBUG */
  27     bcell = mlenv->currentCell;
  28     mlenv->currentCell = cell;
  29
  30     if (mlenv->searchFTable (*name, t)) {
  31         // normal function.
  32         ans = t->fn (cell, mlenv);
  33     } else if (mlenv->searchMTable (*name, t)) {
  34         // module function.
  35         mlenv->pushMStack (t);
  36         ans = t->fn (cell, mlenv);
  37         mlenv->popMStack ();
  38     } else if (mlenv->searchSTable (*name, t, u)) {
  39         // subfunction.
  40         ans = t->sfn (cell, mlenv, u);
  41     } else if ((sexp = mlenv->getVar (*name)) && isLambda (sexp)) {
  42         MNodeList  list;
  43         MNode*  a = cell->cdr ();
  44         while (a) {
  45             list.append (eval (a->car (), mlenv));
  46             nextNode (a);
  47         }
  48 #ifdef DEBUG
  49         if (mlenv->mlPool->nodebugFunc.get (*name)) {
  50             AutoBackupBool  autoBackup (&mlenv->mlPool->nolog);
  51             mlenv->mlPool->nolog = true;
  52             ans = execDefun (mlenv, sexp, list (), *name);
  53         } else {
  54             ans = execDefun (mlenv, sexp, list (), *name);
  55         }
  56 #else
  57         ans = execDefun (mlenv, sexp, list (), *name);
  58 #endif /* DEBUG */
  59     } else {
  60         // not found
  61         throw (ustring ("undefined function"));
  62     }
  63     mlenv->currentCell = bcell;
  64
  65     return ans.release ();
  66 }
  67
  68 MNode*  eval (MNode* cell, MlEnv* mlenv) {
  69     if (! cell)
  70         return NULL;
  71     switch (cell->type) {
  72     case MNode::MC_NIL:
  73         return NULL;
  74     case MNode::MC_CONS:
  75         if (cell->car ()
  76             && cell->car ()->isSym ()
  77             && (cell->cdr () == NULL || cell->cdr ()->isCons ())) {
  78             return callFunc (cell, mlenv);
  79         } else {
  80             throw (cell->dump_string_short () + ustring (": error"));
  81         }
  82         break;
  83     case MNode::MC_STR:
  84         return cell;
  85     case MNode::MC_SYM: {
  86         const ustring*  u = ptr_symbol (cell);
  87         if (u->length () > 0) {
  88             switch ((*u)[0]) {
  89             case '#':
  90             case ':':
  91                 return cell;
  92             }
  93         }
  94         return mlenv->getVar (*u);
  95     }
  96     case MNode::MC_DOUBLE:
  97         return cell;
  98     case MNode::MC_VECTOR:
  99         return vectorDup (cell);
 100     case MNode::MC_TABLE:
 101         return tableDup (cell);
 102     default:
 103         assert (0);
 104     }
 105     return NULL;                        // not reached
 106 }
 107
 108 MNode*  vectorDup (MNode* c) {
 109     MNodePtr  ans;
 110     MNode*  x;
 111     MotorVector::iterator  b, e;
 112
 113     assert (c && c->isVector ());
 114     x = newMNode_vector ();
 115     ans = x;
 116     b = c->vector->begin ();
 117     e = c->vector->end ();
 118     for (; b < e; ++ b) {
 119         x->vectorPush ((*b) ());
 120     }
 121     return ans.release ();
 122 }
 123
 124 MNode*  vectorEval (MNode* c, MlEnv* mlenv) {
 125     MNodePtr  ans;
 126     MNode*  x;
 127     MotorVector::iterator  b, e;
 128
 129     assert (c && c->isVector ());
 130     x = newMNode_vector ();
 131     ans = x;
 132     b = c->vector->begin ();
 133     e = c->vector->end ();
 134     for (; b < e; ++ b) {
 135 #ifdef DEBUG2
 136         std::cerr << "eval:" << to_string ((*b) ()) << "\n";
 137 #endif /* DEBUG */
 138         x->vectorPush (eval ((*b) (), mlenv));
 139     }
 140     return ans.release ();
 141 }
 142
 143 MNode*  tableDup (MNode* c) {
 144     MNodePtr  ans;
 145     MNode*  x;
 146     MotorVar::iterator  b, e;
 147
 148     assert (c && c->isTable ());
 149     x = newMNode_table ();
 150     ans = x;
 151     b = c->table->begin ();
 152     e = c->table->end ();
 153     for (; b != e; ++ b) {
 154         x->tablePut ((*b).first, (*b).second ());
 155     }
 156
 157     return ans.release ();
 158 }
 159
 160 MNode*  tableEval (MNode* c, MlEnv* mlenv) {
 161     MNodePtr  ans;
 162     MNode*  x;
 163     MotorVar::iterator  b, e;
 164
 165     assert (c && c->isTable ());
 166     x = newMNode_table ();
 167     ans = x;
 168     b = c->table->begin ();
 169     e = c->table->end ();
 170     for (; b != e; ++ b) {
 171 #ifdef DEBUG2
 172 //      std::cerr << "eval:" << to_string ((*b) ()) << "\n";
 173 #endif /* DEBUG */
 174         x->tablePut ((*b).first, eval ((*b).second (), mlenv)); // テーブルのキーは、文字列。
 175     }
 176
 177     return ans.release ();
 178 }
 179
 180 double  eval_double (MNode* cell, MlEnv* mlenv) {
 181     MNodePtr  p;
 182     p = eval (cell, mlenv);
 183     return to_double (p ());
 184 }
 185
 186 int  eval_int (MNode* cell, MlEnv* mlenv) {
 187     MNodePtr  p;
 188     p = eval (cell, mlenv);
 189     return to_int (p ());
 190 }
 191
 192 int64_t  eval_int64 (MNode* cell, MlEnv* mlenv) {
 193     MNodePtr  p;
 194     p = eval (cell, mlenv);
 195     return to_int64 (p ());
 196 }
 197
 198 ustring  eval_str (MNode* cell, MlEnv* mlenv) {
 199     MNodePtr  p;
 200     p = eval (cell, mlenv);
 201     return to_string (p ());
 202 }
 203
 204 ustring  eval_text1 (MNode* cell, MlEnv* mlenv) {
 205     MNodePtr  p;
 206     p = eval (cell, mlenv);
 207     return to_text1 (p ());
 208 }
 209
 210 ustring  eval_asciiword (MNode* cell, MlEnv* mlenv) {
 211     MNodePtr  p;
 212     p = eval (cell, mlenv);
 213     return to_asciiword (p ());
 214 }
 215
 216 bool  eval_bool (MNode* cell, MlEnv* mlenv) {
 217     MNodePtr  p;
 218     p = eval (cell, mlenv);
 219     return to_bool (p ());
 220 }
 221
 222 ustring  eval_file (MNode* cell, MlEnv* mlenv) {
 223     ustring  ans = eval_str (cell, mlenv);
 224     if (! checkFilename (ans))  // XXX dummy
 225         ans.resize (0);
 226     return ans;
 227 }
 228
 229 MNode*  progn (MNode* arg, MlEnv* mlenv) {
 230     MNodePtr  ans;
 231
 232     if (! arg)
 233         return NULL;
 234
 235     assert (arg->isCons ());
 236     while (arg && ! mlenv->breaksym ()) {
 237         if (arg->car ()) {
 238             ans = eval (arg->car (), mlenv);
 239             if (mlenv->breaksym ())
 240                 return mlenv->breakval ();
 241         } else {
 242             ans = NULL;
 243         }
 244         nextNode (arg);
 245     }
 246     if (mlenv->breaksym ())
 247         return mlenv->breakval ();
 248     return ans.release ();
 249 }
 250
 251 void  progn_ex (MNode* arg, MlEnv* mlenv) {
 252     MNodePtr  ans;
 253
 254     assert (arg && arg->isCons ());
 255     if (arg->cdr () && arg->cdr ()->isCons ()) {
 256         arg = arg->cdr ();
 257         mlenv->mlPool->resetProg ();
 258         while (arg && ! mlenv->breaksym ()) {
 259             if (arg->car () && arg->car ()->isCons ()) {
 260                 ans = eval (arg->car (), mlenv);
 261                 if (mlenv->breaksym ()) {
 262                     mlenv->setBreak (NULL, NULL);
 263                     return;
 264                 }
 265             }
 266             nextNode (arg);
 267         }
 268     }
 269 }
 270
 271 void  checkDefun (MNode* arg, ustring& name, MNode*& sexp) {
 272     MNode*  param;
 273     MNode*  body;
 274     MNode*  a;
 275
 276     if (! arg)
 277         throw (uErrorWrongNumber);
 278     if (! arg->car ())
 279         throw (ustring (CharConst ("bad name.")));
 280
 281     name = arg->car ()->to_string ();
 282     nextNodeNonNil (arg);
 283     sexp = arg;
 284
 285     param = arg->car ();
 286     body = arg->cdr ();
 287     if ((param && ! param->isNil () && ! param->isCons ())
 288         || (body && ! body->isNil () && ! body->isCons ())) {
 289         throw (uErrorWrongType);
 290     }
 291     for (a = param; a && a->isCons (); nextNode (a)) {
 292         if (! a->car () || ! a->car ()->isSym ())
 293             throw (param->dump_string () + uErrorBadType);
 294     }
 295 }
 296
 297 MNode*  newLambda (MNode* cell) {
 298     if (! cell || ! cell->isCons ())
 299         throw (uErrorSyntax);
 300
 301     MNode*  ans = new MNode;
 302
 303     ans->set_car (newMNode_sym (new ustring (uLambda)));
 304     ans->set_cdr (cell);
 305
 306     return ans;
 307 }
 308
 309 MNode*  buildArgs (int start, const std::vector<ustring>& args) {
 310     MNodeList  ans;
 311
 312     for (; start < args.size (); start ++) {
 313         ans.append (newMNode_str (new ustring (args[start])));
 314     }
 315     return ans.release ();
 316 }
 317
 318 MNode*  buildArgs (int start, const std::vector<ustring>& args, const ustring& arg2) {
 319     MNodeList  ans;
 320
 321     ans.append (newMNode_str (new ustring (arg2)));
 322     for (; start < args.size (); start ++) {
 323         ans.append (newMNode_str (new ustring (args[start])));
 324     }
 325     return ans.release ();
 326 }
 327
 328 MNode*  buildArgs (const ustring& arg1) {
 329     MNodeList  ans;
 330
 331     ans.append (newMNode_str (new ustring (arg1)));
 332     return ans.release ();
 333 }
 334
 335 class  KwList: public boost::unordered_map<ustring, std::pair<bool,MNode*> > {
 336 public:
 337     KwList () {};
 338     ~KwList () {};
 339     void  insertVar (const ustring& name, bool f) {
 340         erase (name);
 341         insert (KwList::value_type (name, std::pair<bool,MNode*> (f, NULL)));
 342     };
 343     void  setVar (const ustring& name, MNode* val) {
 344         KwList::iterator  it = find (name);
 345         if (it == end ()) {
 346         } else {
 347             it->second.second = val;
 348         }
 349     };
 350     MNode*  getVar (const ustring& name) {
 351         KwList::iterator  it = find (name);
 352         if (it == end ()) {
 353             return NULL;
 354         } else {
 355             return it->second.second;
 356         }
 357     };
 358     bool  defined (const ustring& name) {
 359         KwList::iterator  it = find (name);
 360         return (it != end ());
 361     };
 362     bool  definedBoolType (const ustring& name) {
 363         KwList::iterator  it = find (name);
 364         return (it != end () && it->second.first);
 365     };
 366 };
 367
 368 bool  checkDefunArgs (MNode* lambda, MNode* values) {
 369     MNode*  sexp = lambda->cdr ();
 370     MNode*  param;
 371     AutoDelete<KwList>  kwlist;
 372     const ustring*  u;
 373     ustring  k;
 374     bool  skip;
 375
 376     for (param = sexp->car (); param; nextNode (param)) {
 377         u = ptr_symbol (param->car ());
 378         if (match (*u, CharConst ("&rest"))) {
 379             break;
 380         } else if (match (*u, CharConst ("&key"))) {
 381             if (kwlist ()) {
 382                 return false;           // &key appeared.
 383             } else {
 384                 kwlist = new KwList;
 385             }
 386         } else {
 387             if (kwlist ()) {
 388                 kwlist ()->insertVar (*u, true);
 389             } else {
 390             }
 391         }
 392     }
 393     skip = false;
 394     for (param = sexp->car (); param;) {
 395         u = NULL;
 396         if (kwlist () && values && values->car ()->isSym ()
 397             && (u = ptr_symbol (values->car ()))->length () > 0
 398             && (*u)[0] == '#'
 399             && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 400             nextNode (values);
 401         } else if (u && u->length () > 0
 402                    && (*u)[0] == ':'
 403                    && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 404             nextNode (values);
 405             nextNode (values);
 406         } else if (match (*(u = ptr_symbol (param->car ())), CharConst ("&rest"))) {
 407             nextNode (param);
 408             if (param) {
 409                 values = NULL;
 410             } else {
 411 //              throw (sexp->car ()->dump_string_short () + uErrorBadParamDef);
 412                 return false;
 413             }
 414             break;
 415         } else if (match (*u, CharConst ("&key"))) {
 416             skip = true;
 417             nextNode (param);
 418         } else {
 419             if (skip) {
 420                 nextNode (param);
 421             } else {
 422                 nextNode (param);
 423                 nextNode (values);
 424             }
 425         }
 426     }
 427     for (; values;) {
 428         u = NULL;
 429         if (kwlist () && values && values->car ()->isSym ()
 430             && (u = ptr_symbol (values->car ()))->length () > 0
 431             && (*u)[0] == '#'
 432             && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 433             nextNode (values);
 434         } else if (u && u->length () > 0
 435                    && (*u)[0] == ':'
 436                    && kwlist ()->defined (ustring (u->begin () + 1, u->end ()))) {
 437             nextNode (values);
 438             nextNode (values);
 439         } else {
 440             return false;
 441         }
 442     }
 443     return true;
 444 }
 445
 446 MNode*  execDefun (MlEnv* mlenv, MotorVar* pool, const ustring& name, MNode* values) {
 447     MNode*  sexp = pool->getVar (name);
 448     if (isLambda (sexp)) {
 449         return execDefun (mlenv, sexp, values, name);
 450     }
 451     return NULL;
 452 }
 453
 454 MNode*  execDefun (MlEnv* mlenv, MNode* lambda, MNode* values, const ustring& name) {
 455     assert (isLambda (lambda));
 456     MNode*  sexp = lambda->cdr ();
 457     MNode*  param;
 458     MNode*  body = sexp->cdr ();
 459     MNodePtr  ans;
 460     AutoDelete<KwList>  kwlist;
 461     const ustring*  u;
 462     ustring  k;
 463     bool  skip;
 464     MNode*  values0 = values;
 465
 466     mlenv->beginLocal ();
 467 // it is assumed that param is a list of symbols.
 468     for (param = sexp->car (); param; nextNode (param)) {
 469         u = ptr_symbol (param->car ());
 470         if (match (*u, CharConst ("&rest"))) {
 471             break;
 472         } else if (match (*u, CharConst ("&key"))) {
 473             if (kwlist ()) {
 474                 throw (sexp->car ()->dump_string_short () + uErrorBadParamDef);
 475             } else {
 476                 kwlist = new KwList;
 477             }
 478         } else {
 479             if (kwlist ()) {
 480                 kwlist ()->insertVar (*u, true);
 481                 mlenv->setLocalVar (*u, NULL);
 482             } else {
 483             }
 484         }
 485     }
 486
 487     skip = false;
 488     for (param = sexp->car (); param;) {
 489         u = NULL;
 490         if (kwlist () && values && values->car () && values->car ()->isSym ()
 491             && (u = ptr_symbol (values->car ()))->length () > 0
 492             && (*u)[0] == '#'
 493             && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 494             mlenv->setLocalVar (k, mlTrue);
 495             nextNode (values);
 496         } else if (u && u->length () > 0
 497                    && (*u)[0] == ':'
 498                    && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 499             nextNode (values);
 500             if (values)
 501                 mlenv->setLocalVar (k, values->car ());
 502             else
 503                 mlenv->setLocalVar (k, NULL);
 504             nextNode (values);
 505         } else if (match (*(u = ptr_symbol (param->car ())), CharConst ("&rest"))) {
 506             nextNode (param);
 507             if (param) {
 508                 mlenv->setLocalVar (*ptr_symbol (param->car ()), values);
 509                 values = NULL;
 510             } else {
 511                 throw (sexp->car ()->dump_string_short () + uErrorBadParamDef);
 512             }
 513             break;
 514         } else if (match (*u, CharConst ("&key"))) {
 515             skip = true;
 516             nextNode (param);
 517         } else {
 518             if (skip) {
 519                 nextNode (param);
 520             } else {
 521                 if (values)
 522                     mlenv->setLocalVar (*u, values->car ());
 523                 else
 524                     mlenv->setLocalVar (*u, NULL);
 525                 nextNode (param);
 526                 nextNode (values);
 527             }
 528         }
 529     }
 530     for (; values;) {
 531         u = NULL;
 532         if (kwlist () && values && values->car ()->isSym ()
 533             && (u = ptr_symbol (values->car ()))->length () > 0
 534             && (*u)[0] == '#'
 535             && kwlist ()->defined (k = ustring (u->begin () + 1, u->end ()))) {
 536             mlenv->setLocalVar (k, mlTrue);
 537             nextNode (values);
 538         } else if (u && u->length () > 0
 539                    && (*u)[0] == ':'
 540                    && kwlist ()->defined (ustring (u->begin () + 1, u->end ()))) {
 541             nextNode (values);
 542             if (values)
 543                 mlenv->setLocalVar (k, values->car ());
 544             else
 545                 mlenv->setLocalVar (k, NULL);
 546             nextNode (values);
 547         } else {
 548 //          throw (uErrorWrongNumber);
 549 //          throw (lambda->dump_string_short () + values0->dump_string_short () + ": " + uErrorWrongNumber);
 550             MNodePtr  a;
 551             a = new MNode;
 552             a ()->set_car (newMNode_sym (new ustring (name)));
 553             a ()->set_cdr (values0);
 554             throw (a ()->dump_string_short () + ": " + uErrorWrongNumber);
 555         }
 556     }
 557
 558     ans = progn (body, mlenv);
 559     mlenv->stopBreak (lambda->car ());
 560     mlenv->endLocal ();
 561
 562     return ans.release ();
 563 }
 564
 565 void  onErrorFn (MNode* fn, MlEnv* mlenv) {
 566     MNodePtr  v;
 567     MNodePtr  ag;
 568
 569     ag = new MNode;
 570     ag ()->set_car (mlenv->currentCell ());
 571     v = execDefun (mlenv, fn, ag (), uEmpty);
 572 }
 573
 574 void  setParams (MNode* list, int nparam, std::vector<MNode*>* params, paramList *kwlist, std::vector<MNode*>* keywords, MNode** rest, bool padding) {
 575     KwList*  kw = NULL;
 576     const ustring*  u;
 577     MNode*  a;
 578     int  i;
 579     ustring  name;
 580
 581     if (kwlist) {
 582         kw = new KwList;
 583         for (i = 0; kwlist[i].name; i ++) {
 584             kw->insertVar (ustring (kwlist[i].name, kwlist[i].namelen), kwlist[i].fbool);
 585         }
 586     }
 587
 588     while (list) {
 589         a = list->car ();
 590         if (a && kw && a->isSym () && (u = ptr_symbol (a)) && u->size () > 0) {
 591             switch ((*u)[0]) {
 592             case ':':
 593                 name = ustring (u->begin () + 1, u->end ());
 594                 if (kw->defined (name)) {
 595                     nextNode (list);
 596                     if (list) {
 597                         kw->setVar (name, list->car ());
 598                         nextNode (list);
 599                     } else {
 600                         delete kw;
 601                         throw (uErrorWrongNumber);
 602                     }
 603                 } else {
 604                     delete kw;
 605                     throw (uQ2 + *u + uQ2 + uErrorBadParam);
 606                 }
 607                 break;
 608             case '#':
 609                 name = ustring (u->begin () + 1, u->end ());
 610                 if (kw->definedBoolType (name)) {
 611                     nextNode (list);
 612                     kw->setVar (name, mlTrue);
 613                 } else {
 614                     delete kw;
 615                     throw (uQ2 + *u + uQ2 + uErrorBadParam);
 616                 }
 617                 break;
 618             default:
 619                 goto Bp1;
 620             }
 621         } else {
 622         Bp1:;
 623             if (params && (params->size () < nparam || (nparam == 0 && rest == NULL))) {
 624                 nextNode (list);
 625                 params->push_back (a);
 626             } else {
 627                 break;
 628             }
 629         }
 630     }
 631
 632     if (rest) {
 633         *rest = list;
 634     } else if (list) {
 635         delete kw;
 636         throw (uErrorWrongNumber);
 637     }
 638
 639     if (params && params->size () < nparam) {
 640         if (padding) {
 641             while (params->size () < nparam) {
 642                 params->push_back (NULL);
 643             }
 644         } else {
 645             delete kw;
 646             throw (uErrorWrongNumber);
 647         }
 648     }
 649
 650     if (kwlist && keywords) {
 651         for (i = 0; kwlist[i].name; i ++) {
 652             keywords->push_back (kw->getVar (ustring (kwlist[i].name, kwlist[i].namelen)));
 653         }
 654     }
 655
 656     delete kw;
 657 }