lib/scm.c

   1 /* Copyright(C) 2006-2007 Brazil
   2
   3   This library is free software; you can redistribute it and/or
   4   modify it under the terms of the GNU Lesser General Public
   5   License as published by the Free Software Foundation; either
   6   version 2.1 of the License, or (at your option) any later version.
   7
   8   This library is distributed in the hope that it will be useful,
   9   but WITHOUT ANY WARRANTY; without even the implied warranty of
  10   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11   Lesser General Public License for more details.
  12
  13   You should have received a copy of the GNU Lesser General Public
  14   License along with this library; if not, write to the Free Software
  15   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16 */
  17
  18 /*  Senna Query Language is based on Mini-Scheme, original credits follow  */
  19
  20 /*
  21  *      ---------- Mini-Scheme Interpreter Version 0.85 ----------
  22  *
  23  *                coded by Atsushi Moriwaki (11/5/1989)
  24  *
  25  *            E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
  26  *
  27  *               THIS SOFTWARE IS IN THE PUBLIC DOMAIN
  28  *               ------------------------------------
  29  * This software is completely free to copy, modify and/or re-distribute.
  30  * But I would appreciate it if you left my name on the code as the author.
  31  *
  32  */
  33 /*--
  34  *
  35  *  This version has been modified by R.C. Secrist.
  36  *
  37  *  Mini-Scheme is now maintained by Akira KIDA.
  38  *
  39  *  This is a revised and modified version by Akira KIDA.
  40  *  current version is 0.85k4 (15 May 1994)
  41  *
  42  *  Please send suggestions, bug reports and/or requests to:
  43  *    <SDI00379@niftyserve.or.jp>
  44  *--
  45  */
  46
  47 #include "senna_in.h"
  48 #include <fcntl.h>
  49 #include <string.h>
  50 #include <sys/stat.h>
  51 #include <sys/types.h>
  52 #include "ql.h"
  53
  54 #define InitFile "init.scm"
  55
  56 /* global variables */
  57
  58 sen_obj *sen_ql_nil;  /* special cell representing empty cell */
  59 sen_obj *sen_ql_t;    /* special cell representing #t */
  60 sen_obj *sen_ql_f;    /* special cell representing #f */
  61
  62 /* sen query language */
  63
  64 /* todo : update set-car! set-cdr!
  65
  66 inline static void
  67 obj_ref(sen_obj *o)
  68 {
  69   if (o->nrefs < 0xffff) { o->nrefs++; }
  70   if (PAIRP(o)) { // todo : check cycle
  71     if (CAR(o) != NIL) { obj_ref(CAR(o)); }
  72     if (CDR(o) != NIL) { obj_ref(CDR(o)); }
  73   }
  74 }
  75
  76 inline static void
  77 obj_unref(sen_obj *o)
  78 {
  79   if (!o->nrefs) {
  80     SEN_LOG(sen_log_error, "o->nrefs corrupt");
  81     return;
  82   }
  83   if (o->nrefs < 0xffff) { o->nrefs--; }
  84   if (PAIRP(o)) { // todo : check cycle
  85     if (CAR(o) != NIL) { obj_unref(CAR(o)); }
  86     if (CDR(o) != NIL) { obj_unref(CDR(o)); }
  87   }
  88 }
  89
  90 inline static void
  91 rplaca(sen_ctx *ctx, sen_obj *a, sen_obj *b)
  92 {
  93   if (a->nrefs) {
  94     ctx->nbinds++;
  95     if (a->u.l.car) {
  96       ctx->nunbinds++;
  97       obj_unref(a->u.l.car);
  98     }
  99     if (b) { obj_ref(b); }
 100   }
 101   a->u.l.car = b;
 102 }
 103
 104 inline static void
 105 rplacd(sen_ctx *ctx, sen_obj *a, sen_obj *b)
 106 {
 107   if (a->nrefs) {
 108     ctx->nbinds++;
 109     if (a->u.l.cdr) {
 110       ctx->nunbinds++;
 111       obj_unref(a->u.l.cdr);
 112     }
 113     if (b) { obj_ref(b); }
 114   }
 115   a->u.l.cdr = b;
 116 }
 117
 118 */
 119
 120 sen_rc
 121 sen_obj2int(sen_ctx *ctx, sen_obj *o)
 122 {
 123   sen_rc rc = sen_invalid_argument;
 124   if (o) {
 125     switch (o->type) {
 126     case sen_ql_bulk :
 127       if (o->u.b.size) {
 128         const char *end = o->u.b.value + o->u.b.size, *rest;
 129         int64_t i = sen_atoll(o->u.b.value, end, &rest);
 130         if (rest == end) {
 131           sen_obj_clear(ctx, o);
 132           SETINT(o, i);
 133           rc = sen_success;
 134         }
 135       }
 136       break;
 137     case sen_ql_int :
 138       rc = sen_success;
 139       break;
 140     default :
 141       break;
 142     }
 143   }
 144   return rc;
 145 }
 146
 147 /* get new symbol */
 148 sen_obj *
 149 sen_ql_mk_symbol(sen_ctx *ctx, const char *name)
 150 {
 151   sen_obj *x;
 152   if (!sen_set_get(ctx->symbols, name, (void **) &x)) { return F; }
 153   if (!x->flags) {
 154     x->flags |= SEN_OBJ_SYMBOL;
 155     x->type = sen_ql_void;
 156   }
 157   if (x->type == sen_ql_void && ctx->db) {
 158     sen_db_store *slot = sen_db_store_open(ctx->db, SYMNAME(x));
 159     if (slot) { sen_ql_bind_symbol(slot, x); }
 160   }
 161   return x;
 162 }
 163
 164 sen_obj *
 165 sen_ql_at(sen_ctx *ctx, const char *key)
 166 {
 167   sen_obj *o;
 168   if (!sen_set_at(ctx->symbols, key, (void **) &o)) {
 169     return NULL;
 170   }
 171   return o;
 172 }
 173
 174 void
 175 sen_ql_def_native_func(sen_ctx *ctx, const char *name, sen_ql_native_func *func)
 176 {
 177   sen_obj *o = INTERN(name);
 178   if (o != F) {
 179     o->type = sen_ql_void;
 180     o->flags |= SEN_OBJ_NATIVE;
 181     o->u.o.func = func;
 182   }
 183 }
 184
 185 inline static void
 186 sen_ctx_igc(sen_ctx *ctx)
 187 {
 188   uint32_t i;
 189   sen_obj *o;
 190   sen_set_eh *ep;
 191   for (i = ctx->lseqno; i != ctx->seqno; i++) {
 192     if ((ep = sen_set_at(ctx->objects, &i, (void **) &o))) {
 193       if (ctx->nbinds &&
 194           (o->nrefs ||
 195            (BULKP(o) && (o->flags & SEN_OBJ_ALLOCATED)))) { continue; }
 196       sen_obj_clear(ctx, o);
 197       sen_set_del(ctx->objects, ep);
 198     }
 199   }
 200   ctx->lseqno = ctx->seqno;
 201   ctx->nbinds = 0;
 202 }
 203
 204 #define MARKP(p)        ((p)->flags & SEN_OBJ_MARKED)
 205 #define REFERERP(p)     ((p)->flags & SEN_OBJ_REFERER)
 206 #define SETREFERER(p)   ((p)->flags |= SEN_OBJ_REFERER)
 207 #define UNSETREFERER(p) ((p)->flags &= ~SEN_OBJ_REFERER)
 208
 209 /*--
 210  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
 211  *  sec.3.5) for marking.
 212  */
 213 inline static void
 214 obj_mark(sen_ctx *ctx, sen_obj *o)
 215 {
 216   sen_obj *t, *q, *p;
 217   t = NULL;
 218   p = o;
 219   // if (MARKP(o)) { return; }
 220 E2:
 221   p->flags |= SEN_OBJ_MARKED;
 222   // if (!o->nrefs) { SEN_LOG(sen_log_error, "obj->nrefs corrupt"); }
 223   if (BULKP(o) && !(o->flags & SEN_OBJ_ALLOCATED)) {
 224     char *b = SEN_MALLOC(o->u.b.size + 1);
 225     if (b) {
 226       memcpy(b, o->u.b.value, o->u.b.size);
 227       b[o->u.b.size] = '\0';
 228       o->u.b.value = b;
 229       o->flags |= SEN_OBJ_ALLOCATED;
 230     }
 231   }
 232   if (!REFERERP(p)) { goto E6; }
 233   q = CAR(p);
 234   if (q && !MARKP(q)) {
 235     UNSETREFERER(p);
 236     CAR(p) = t;
 237     t = p;
 238     p = q;
 239     goto E2;
 240   }
 241 E5:
 242   q = CDR(p);
 243   if (q && !MARKP(q)) {
 244     CDR(p) = t;
 245     t = p;
 246     p = q;
 247     goto E2;
 248   }
 249 E6:
 250   if (!t) { return; }
 251   q = t;
 252   if (!REFERERP(q)) {
 253     SETREFERER(q);
 254     t = CAR(q);
 255     CAR(q) = p;
 256     p = q;
 257     goto E5;
 258   } else {
 259     t = CDR(q);
 260     CDR(q) = p;
 261     p = q;
 262     goto E6;
 263   }
 264 }
 265
 266 inline static sen_rc
 267 sen_ctx_mgc(sen_ctx *ctx)
 268 {
 269   sen_set_cursor *sc;
 270   /*
 271   if (!(sc = sen_set_cursor_open(ctx->symbols))) { return sen_memory_exhausted; }
 272   {
 273     sen_obj *o;
 274     while (sen_set_cursor_next(sc, NULL, (void **) &o)) { obj_mark(o); }
 275     sen_set_cursor_close(sc);
 276   }
 277   */
 278   obj_mark(ctx, ctx->global_env);
 279
 280   /* mark current registers */
 281   obj_mark(ctx, ctx->args);
 282   obj_mark(ctx, ctx->envir);
 283   obj_mark(ctx, ctx->code);
 284   obj_mark(ctx, ctx->dump);
 285   obj_mark(ctx, ctx->value);
 286   obj_mark(ctx, ctx->phs);
 287
 288   if (!(sc = sen_set_cursor_open(ctx->objects))) { return sen_memory_exhausted; }
 289   {
 290     sen_obj *o;
 291     sen_set_eh *ep;
 292     while ((ep = sen_set_cursor_next(sc, NULL, (void **) &o))) {
 293       if (o->flags & SEN_OBJ_MARKED) {
 294         o->flags &= ~SEN_OBJ_MARKED;
 295       } else {
 296         sen_obj_clear(ctx, o);
 297         sen_set_del(ctx->objects, ep);
 298       }
 299     }
 300   }
 301   sen_set_cursor_close(sc);
 302   ctx->lseqno = ctx->seqno;
 303   ctx->nbinds = 0;
 304   ctx->nunbinds = 0;
 305   return sen_success;
 306 }
 307
 308 inline static void Eval_Cycle(sen_ctx *ctx);
 309
 310 /* ========== Evaluation Cycle ========== */
 311
 312 /* operator code */
 313
 314 enum {
 315   OP_T0LVL = SEN_OP_T0LVL,
 316   OP_ERR0 = SEN_OP_ERR0,
 317   OP_LOAD,
 318   OP_T1LVL,
 319   OP_READ,
 320   OP_VALUEPRINT,
 321   OP_EVAL,
 322   OP_E0ARGS,
 323   OP_E1ARGS,
 324   OP_APPLY,
 325   OP_DOMACRO,
 326   OP_LAMBDA,
 327   OP_QUOTE,
 328   OP_DEF0,
 329   OP_DEF1,
 330   OP_BEGIN,
 331   OP_IF0,
 332   OP_IF1,
 333   OP_SET0,
 334   OP_SET1,
 335   OP_LET0,
 336   OP_LET1,
 337   OP_LET2,
 338   OP_LET0AST,
 339   OP_LET1AST,
 340   OP_LET2AST,
 341   OP_LET0REC,
 342   OP_LET1REC,
 343   OP_LET2REC,
 344   OP_COND0,
 345   OP_COND1,
 346   OP_DELAY,
 347   OP_AND0,
 348   OP_AND1,
 349   OP_OR0,
 350   OP_OR1,
 351   OP_C0STREAM,
 352   OP_C1STREAM,
 353   OP_0MACRO,
 354   OP_1MACRO,
 355   OP_CASE0,
 356   OP_CASE1,
 357   OP_CASE2,
 358   OP_PEVAL,
 359   OP_PAPPLY,
 360   OP_CONTINUATION,
 361   OP_SETCAR,
 362   OP_SETCDR,
 363   OP_FORCE,
 364   OP_ERR1,
 365   OP_PUT,
 366   OP_GET,
 367   OP_QUIT,
 368   OP_SDOWN,
 369   OP_RDSEXPR,
 370   OP_RDLIST,
 371   OP_RDDOT,
 372   OP_RDQUOTE,
 373   OP_RDQQUOTE,
 374   OP_RDUNQUOTE,
 375   OP_RDUQTSP,
 376   OP_NATIVE,
 377   OP_QQUOTE0,
 378   OP_QQUOTE1,
 379   OP_QQUOTE2
 380 };
 381
 382 sen_obj *
 383 sen_ql_feed(sen_ctx *ctx, char *str, uint32_t str_size, int mode)
 384 {
 385   if (SEN_QL_WAITINGP(ctx)) {
 386     SEN_RBUF_REWIND(&ctx->outbuf);
 387     SEN_RBUF_REWIND(&ctx->subbuf);
 388     ctx->bufcur = 0;
 389   }
 390   for (;;) {
 391     switch (ctx->stat) {
 392     case SEN_QL_TOPLEVEL :
 393       ctx->co.mode &= ~SEN_CTX_HEAD;
 394       Eval_Cycle(ctx);
 395       break;
 396     case SEN_QL_WAIT_EXPR :
 397       ctx->co.mode = mode;
 398       ctx->cur = str;
 399       ctx->str_end = str + str_size;
 400       Eval_Cycle(ctx);
 401       break;
 402     case SEN_QL_WAIT_ARG :
 403       ctx->co.mode = mode;
 404       if ((mode & SEN_CTX_HEAD)) {
 405         ctx->cur = str;
 406         ctx->str_end = str + str_size;
 407       } else {
 408         char *buf;
 409         sen_obj *ph = CAR(ctx->phs);
 410         if (!(buf = SEN_MALLOC(str_size + 1))) {
 411           return NIL;
 412         }
 413         memcpy(buf, str, str_size);
 414         buf[str_size] = '\0';
 415         ph->flags |= SEN_OBJ_ALLOCATED;
 416         ph->u.b.value = buf;
 417         ph->u.b.size = str_size;
 418         ctx->phs = CDR(ctx->phs);
 419       }
 420       if ((ctx->phs == NIL) || (mode & (SEN_CTX_HEAD|SEN_CTX_TAIL))) {
 421         ctx->stat = SEN_QL_EVAL;
 422       }
 423       break;
 424     case SEN_QL_EVAL :
 425       Eval_Cycle(ctx);
 426       break;
 427     case SEN_QL_WAIT_DATA :
 428       ctx->co.mode = mode;
 429       if ((mode & SEN_CTX_HEAD)) {
 430         ctx->args = NIL;
 431         ctx->cur = str;
 432         ctx->str_end = str + str_size;
 433       } else {
 434         ctx->arg.u.b.value = str;
 435         ctx->arg.u.b.size = str_size;
 436         ctx->arg.type = sen_ql_bulk;
 437         ctx->args = &ctx->arg;
 438       }
 439       /* fall through */
 440     case SEN_QL_NATIVE :
 441       SEN_ASSERT(ctx->co.func);
 442       ctx->value = ctx->co.func(ctx, ctx->args, &ctx->co);
 443       if (ERRP(ctx, SEN_ERROR)) { ctx->stat = SEN_QL_QUITTING; return F; }
 444       ERRCLR(ctx);
 445       if (ctx->co.last && !(ctx->co.mode & (SEN_CTX_HEAD|SEN_CTX_TAIL))) {
 446         ctx->stat = SEN_QL_WAIT_DATA;
 447       } else {
 448         ctx->co.mode = 0;
 449         Eval_Cycle(ctx);
 450       }
 451       break;
 452     case SEN_QL_QUITTING:
 453       return NIL;
 454     }
 455     if (ERRP(ctx, SEN_ERROR)) { ctx->stat = SEN_QL_QUITTING; return F; }
 456     if (SEN_QL_WAITINGP(ctx)) { /* waiting input data */
 457       if (ctx->inbuf) {
 458         SEN_FREE(ctx->inbuf);
 459         ctx->inbuf = NULL;
 460       }
 461       break;
 462     }
 463     if ((ctx->stat & 0x40) && SEN_QL_GET_MODE(ctx) == sen_ql_step) {
 464       break;
 465     }
 466   }
 467   return NIL;
 468 }
 469
 470 /**** sexp parser ****/
 471
 472 typedef sen_obj cell;
 473
 474 inline static void
 475 skipline(sen_ctx *ctx)
 476 {
 477   while (ctx->cur < ctx->str_end) {
 478     if (*ctx->cur++ == '\n') { break; }
 479   }
 480 }
 481
 482 /*************** scheme interpreter ***************/
 483
 484 # define BACKQUOTE '`'
 485
 486 #include <stdio.h>
 487 #include <ctype.h>
 488
 489 /* macros for cell operations */
 490 #define HASPROP(p)       ((p)->flags & SEN_OBJ_SYMBOL)
 491 #define SYMPROP(p)       CDR(p)
 492 #define SYNTAXP(p)       ((p)->type == sen_ql_syntax)
 493 #define PROCP(p)         ((p)->type == sen_ql_proc)
 494 #define SYNTAXNAME(p)    SYMNAME(p)
 495 #define SYNTAXNUM(p)     ((p)->class)
 496 #define PROCNUM(p)       IVALUE(p)
 497 #define CLOSUREP(p)      ((p)->type == sen_ql_closure)
 498 #define MACROP(p)        ((p)->flags & SEN_OBJ_MACRO)
 499 #define CLOSURE_CODE(p)  CAR(p)
 500 #define CLOSURE_ENV(p)   CDR(p)
 501 #define CONTINUATIONP(p) ((p)->type == sen_ql_continuation)
 502 #define CONT_DUMP(p)     CDR(p)
 503 #define PROMISEP(p)      ((p)->flags & SEN_OBJ_PROMISE)
 504 #define SETPROMISE(p)    (p)->flags |= SEN_OBJ_PROMISE
 505 #define LAMBDA           (INTERN("lambda"))
 506 #define QUOTE            (INTERN("quote"))
 507 #define QQUOTE           (INTERN("quasiquote"))
 508 #define UNQUOTE          (INTERN("unquote"))
 509 #define UNQUOTESP        (INTERN("unquote-splicing"))
 510
 511 /* get new cell.  parameter a, b is marked by gc. */
 512 #define GET_CELL(ctx,a,b,o) SEN_OBJ_NEW(ctx, o)
 513
 514 /* get number atom */
 515 inline static cell *
 516 mk_number(sen_ctx *ctx, int64_t num)
 517 {
 518   cell *x;
 519   SEN_OBJ_NEW(ctx, x);
 520   SETINT(x, num);
 521   return x;
 522 }
 523
 524 /* get new string */
 525 sen_obj *
 526 sen_ql_mk_string(sen_ctx *ctx, const char *str, unsigned int len)
 527 {
 528   cell *x = sen_obj_alloc(ctx, len);
 529   if (!x) { return F; }
 530   memcpy(x->u.b.value, str, len);
 531   x->u.b.value[len] = '\0';
 532   return x;
 533 }
 534
 535 inline static cell *
 536 mk_const_string(sen_ctx *ctx, const char *str)
 537 {
 538   cell *x;
 539   SEN_OBJ_NEW(ctx, x);
 540   x->flags = 0;
 541   x->type = sen_ql_bulk;
 542   x->u.b.value = (char *)str;
 543   x->u.b.size = strlen(str);
 544   return x;
 545 }
 546
 547 inline static cell *
 548 sen_ql_mk_symbol2(sen_ctx *ctx, const char *q, unsigned int len, int kwdp)
 549 {
 550   char buf[SEN_SYM_MAX_KEY_SIZE], *p = buf;
 551   if (len + 1 >= SEN_SYM_MAX_KEY_SIZE) { QLERR("too long symbol"); }
 552   if (kwdp) { *p++ = ':'; }
 553   memcpy(p, q, len);
 554   p[len] = '\0';
 555   return INTERN(buf);
 556 }
 557
 558 inline static cell *
 559 str2num(sen_ctx *ctx, char *str, unsigned int len)
 560 {
 561   const char *cur, *str_end = str + len;
 562   int64_t i = sen_atoll(str, str_end, &cur);
 563   if (cur == str_end) { return mk_number(ctx, i); }
 564   if (cur != str) { /* todo : support #i notation */
 565     char *end, buf0[128], *buf = len < 128 ? buf0 : SEN_MALLOC(len + 1);
 566     if (buf) {
 567       double d;
 568       memcpy(buf, str, len);
 569       buf[len] = '\0';
 570       errno = 0;
 571       d = strtod(buf, &end);
 572       if (!(len < 128)) { SEN_FREE(buf); }
 573       if (!errno && buf + len == end) {
 574         cell *x;
 575         SEN_OBJ_NEW(ctx, x);
 576         SETFLOAT(x, d);
 577         return x;
 578       }
 579     }
 580   }
 581   return NIL;
 582 }
 583
 584 /* make symbol or number atom from string */
 585 inline static cell *
 586 mk_atom(sen_ctx *ctx, char *str, unsigned int len, cell *v)
 587 {
 588   cell **vp = &v, *p;
 589   const char *cur, *last, *str_end = str + len;
 590   if ((p = str2num(ctx, str, len)) != NIL) { return p; }
 591   for (last = cur = str; cur < str_end; cur += len) {
 592     if (!(len = sen_str_charlen_nonnull(cur, str_end, ctx->encoding))) { break; }
 593     if (*cur == '.') {
 594       if (last < cur) { *vp = sen_ql_mk_symbol2(ctx, last, cur - last, str != last); }
 595       v = CONS(v, CONS(NIL, NIL));
 596       vp = &CADR(v);
 597       last = cur + 1;
 598     }
 599   }
 600   if (last < cur) { *vp = sen_ql_mk_symbol2(ctx, last, cur - last, str != last); }
 601   return v;
 602 }
 603
 604 /* make constant */
 605 inline static cell *
 606 mk_const(sen_ctx *ctx, char *name, unsigned int len)
 607 {
 608   int64_t x;
 609   char    tmp[256];
 610   char    tmp2[256];
 611   /* todo : rewirte with sen_str_* functions */
 612   if (len == 1) {
 613     if (*name == 't') {
 614       return T;
 615     } else if (*name == 'f') {
 616       return F;
 617     }
 618   } else if (len > 1) {
 619     if (*name == 'p' && name[1] == '<' && name[12] == '>') {/* #p (sen_ql_object) */
 620       sen_id cls = sen_str_btoi(name + 2);
 621       if (cls) {
 622         sen_id self = sen_str_btoi(name + 7);
 623         if (self) {
 624           cell * v = sen_ql_mk_obj(ctx, cls, self);
 625           if (len > 13 && name[13] == '.') {
 626             return mk_atom(ctx, name + 13, len - 13, v);
 627           } else {
 628             return v;
 629           }
 630         }
 631       }
 632     } else if (*name == ':' && name[1] == '<') {/* #: (sen_ql_time) */
 633       cell *x;
 634       sen_timeval tv;
 635       const char *cur;
 636       tv.tv_sec = sen_atoi(name + 2, name + len, &cur);
 637       if (cur >= name + len || *cur != '.') {
 638         QLERR("illegal time format '%s'", name);
 639       }
 640       tv.tv_usec = sen_atoi(cur + 1, name + len, &cur);
 641       if (cur >= name + len || *cur != '>') {
 642         QLERR("illegal time format '%s'", name);
 643       }
 644       SEN_OBJ_NEW(ctx, x);
 645       SETTIME(x, &tv);
 646       return x;
 647     } else if (*name == 'o') {/* #o (octal) */
 648       len = (len > 255) ? 255 : len - 1;
 649       memcpy(tmp2, name + 1, len);
 650       tmp2[len] = '\0';
 651       sprintf(tmp, "0%s", tmp2);
 652       sscanf(tmp, "%Lo", &x);
 653       return mk_number(ctx, x);
 654     } else if (*name == 'd') {  /* #d (decimal) */
 655       sscanf(&name[1], "%Ld", &x);
 656       return mk_number(ctx, x);
 657     } else if (*name == 'x') {  /* #x (hex) */
 658       len = (len > 255) ? 255 : len - 1;
 659       memcpy(tmp2, name + 1, len);
 660       tmp2[len] = '\0';
 661       sprintf(tmp, "0x%s", tmp2);
 662       sscanf(tmp, "%Lx", &x);
 663       return mk_number(ctx, x);
 664     }
 665   }
 666   return NIL;
 667 }
 668
 669 sen_rc
 670 sen_ctx_load(sen_ctx *ctx, const char *filename)
 671 {
 672   if (!filename) { filename = InitFile; }
 673   ctx->args = CONS(mk_const_string(ctx, filename), NIL);
 674   ctx->stat = SEN_QL_TOPLEVEL;
 675   ctx->op = OP_LOAD;
 676   return sen_ql_feed(ctx, "init", 4, 0) == F ? sen_success : sen_internal_error;
 677 }
 678
 679 /* ========== Routines for Reading ========== */
 680
 681 #define TOK_LPAREN  0
 682 #define TOK_RPAREN  1
 683 #define TOK_DOT     2
 684 #define TOK_ATOM    3
 685 #define TOK_QUOTE   4
 686 #define TOK_COMMENT 5
 687 #define TOK_DQUOTE  6
 688 #define TOK_BQUOTE  7
 689 #define TOK_COMMA   8
 690 #define TOK_ATMARK  9
 691 #define TOK_SHARP   10
 692 #define TOK_EOS     11
 693 #define TOK_QUESTION 12
 694
 695 #define lparenp(c) ((c) == '(' || (c) == '[')
 696 #define rparenp(c) ((c) == ')' || (c) == ']')
 697
 698 /* read chacters to delimiter */
 699 inline static char
 700 readstr(sen_ctx *ctx, char **str, unsigned int *size)
 701 {
 702   char *start, *end;
 703   for (start = end = ctx->cur;;) {
 704     unsigned int len;
 705     /* null check and length check */
 706     if (!(len = sen_str_charlen_nonnull(end, ctx->str_end, ctx->encoding))) {
 707       ctx->cur = ctx->str_end;
 708       break;
 709     }
 710     if (sen_isspace(end, ctx->encoding) ||
 711         *end == ';' || lparenp(*end) || rparenp(*end)) {
 712       ctx->cur = end;
 713       break;
 714     }
 715     end += len;
 716   }
 717   if (start < end || ctx->cur < ctx->str_end) {
 718     *str = start;
 719     *size = (unsigned int)(end - start);
 720     return TOK_ATOM;
 721   } else {
 722     return TOK_EOS;
 723   }
 724 }
 725
 726 /* read string expression "xxx...xxx" */
 727 inline static char
 728 readstrexp(sen_ctx *ctx, char **str, unsigned int *size)
 729 {
 730   char *start, *src, *dest;
 731   for (start = src = dest = ctx->cur;;) {
 732     unsigned int len;
 733     /* null check and length check */
 734     if (!(len = sen_str_charlen_nonnull(src, ctx->str_end, ctx->encoding))) {
 735       ctx->cur = ctx->str_end;
 736       if (start < dest) {
 737         *str = start;
 738         *size = (unsigned int)(dest - start);
 739         return TOK_ATOM;
 740       }
 741       return TOK_EOS;
 742     }
 743     if (src[0] == '"' && len == 1) {
 744       ctx->cur = src + 1;
 745       *str = start;
 746       *size = (unsigned int)(dest - start);
 747       return TOK_ATOM;
 748     } else if (src[0] == '\\' && src + 1 < ctx->str_end && len == 1) {
 749       src++;
 750       *dest++ = *src++;
 751     } else {
 752       while (len--) { *dest++ = *src++; }
 753     }
 754   }
 755 }
 756
 757 /* get token */
 758 inline static char
 759 token(sen_ctx *ctx)
 760 {
 761   SKIPSPACE(ctx);
 762   if (ctx->cur >= ctx->str_end) { return TOK_EOS; }
 763   switch (*ctx->cur) {
 764   case '(':
 765   case '[':
 766     ctx->cur++;
 767     return TOK_LPAREN;
 768   case ')':
 769   case ']':
 770     ctx->cur++;
 771     return TOK_RPAREN;
 772   case '.':
 773     ctx->cur++;
 774     if (ctx->cur == ctx->str_end ||
 775         sen_isspace(ctx->cur, ctx->encoding) ||
 776         *ctx->cur == ';' || lparenp(*ctx->cur) || rparenp(*ctx->cur)) {
 777       return TOK_DOT;
 778     } else {
 779       ctx->cur--;
 780       return TOK_ATOM;
 781     }
 782   case '\'':
 783     ctx->cur++;
 784     return TOK_QUOTE;
 785   case ';':
 786     ctx->cur++;
 787     return TOK_COMMENT;
 788   case '"':
 789     ctx->cur++;
 790     return TOK_DQUOTE;
 791   case BACKQUOTE:
 792     ctx->cur++;
 793     return TOK_BQUOTE;
 794   case ',':
 795     ctx->cur++;
 796     if (ctx->cur < ctx->str_end && *ctx->cur == '@') {
 797       ctx->cur++;
 798       return TOK_ATMARK;
 799     } else {
 800       return TOK_COMMA;
 801     }
 802   case '#':
 803     ctx->cur++;
 804     return TOK_SHARP;
 805   case '?':
 806     ctx->cur++;
 807     return TOK_QUESTION;
 808   default:
 809     return TOK_ATOM;
 810   }
 811 }
 812
 813 /* ========== Routines for Printing ========== */
 814 #define  ok_abbrev(x)  (PAIRP(x) && CDR(x) == NIL)
 815
 816 void
 817 sen_obj_inspect(sen_ctx *ctx, sen_obj *obj, sen_rbuf *buf, int flags)
 818 {
 819   if (!obj) {
 820     SEN_RBUF_PUTS(buf, "NULL");
 821   } else if (obj == NIL) {
 822     SEN_RBUF_PUTS(buf, "()");
 823   } else if (obj == T) {
 824     SEN_RBUF_PUTS(buf, "#t");
 825   } else if (obj == F) {
 826     SEN_RBUF_PUTS(buf, "#f");
 827   } else {
 828     if (SYMBOLP(obj)) {
 829       const char *sym = SYMNAME(obj);
 830       if (sym) {
 831         if (flags & SEN_OBJ_INSPECT_SYM_AS_STR) {
 832           sen_rbuf_str_esc(buf, (*sym == ':') ? sym + 1 : sym, -1, ctx->encoding);
 833         } else {
 834           SEN_RBUF_PUTS(buf, sym);
 835         }
 836         return;
 837       }
 838     }
 839     switch (obj->type) {
 840     case sen_ql_void :
 841       SEN_RBUF_PUTS(buf, SYMBOLP(obj) ? SYMNAME(obj) : "#<VOID>");
 842       break;
 843     case sen_ql_object :
 844       if (flags & SEN_OBJ_INSPECT_ESC) {
 845         SEN_RBUF_PUTS(buf, "#p<");
 846         sen_rbuf_itob(buf, obj->class);
 847         sen_rbuf_itob(buf, obj->u.o.self);
 848         SEN_RBUF_PUTC(buf, '>');
 849       } else {
 850         const char *key = _sen_obj_key(ctx, obj);
 851         SEN_RBUF_PUTS(buf, key ? key : "");
 852       }
 853       break;
 854     case sen_ql_snip :
 855       SEN_RBUF_PUTS(buf, "#<SNIP>");
 856       break;
 857     case sen_ql_records :
 858       SEN_RBUF_PUTS(buf, "#<RECORDS>");
 859       break;
 860     case sen_ql_bulk :
 861       if (flags & SEN_OBJ_INSPECT_ESC) {
 862         sen_rbuf_str_esc(buf, obj->u.b.value, obj->u.b.size, ctx->encoding);
 863       } else {
 864         sen_rbuf_write(buf, obj->u.b.value, obj->u.b.size);
 865       }
 866       break;
 867     case sen_ql_int :
 868       sen_rbuf_lltoa(buf, IVALUE(obj));
 869       break;
 870     case sen_ql_float :
 871       sen_rbuf_ftoa(buf, FVALUE(obj));
 872       break;
 873     case sen_ql_time :
 874       SEN_RBUF_PUTS(buf, "#:<");
 875       sen_rbuf_itoa(buf, obj->u.tv.tv_sec);
 876       SEN_RBUF_PUTS(buf, ".");
 877       sen_rbuf_itoa(buf, obj->u.tv.tv_usec);
 878       SEN_RBUF_PUTC(buf, '>');
 879       break;
 880     case sen_ql_query :
 881       SEN_RBUF_PUTS(buf, "#<QUERY>");
 882       break;
 883     case sen_ql_op :
 884       SEN_RBUF_PUTS(buf, "#<OP>");
 885       break;
 886     case sen_ql_syntax :
 887       SEN_RBUF_PUTS(buf, "#<SYNTAX>");
 888       break;
 889     case sen_ql_proc :
 890       SEN_RBUF_PUTS(buf, "#<PROCEDURE ");
 891       sen_rbuf_itoa(buf, PROCNUM(obj));
 892       SEN_RBUF_PUTS(buf, ">");
 893       break;
 894     case sen_ql_closure :
 895       if (MACROP(obj)) {
 896         SEN_RBUF_PUTS(buf, "#<MACRO>");
 897       } else {
 898         SEN_RBUF_PUTS(buf, "#<CLOSURE>");
 899       }
 900       break;
 901     case sen_ql_continuation :
 902       SEN_RBUF_PUTS(buf, "#<CONTINUATION>");
 903       break;
 904     case sen_db_raw_class :
 905       SEN_RBUF_PUTS(buf, "#<RAW_CLASS>");
 906       break;
 907     case sen_db_class :
 908       SEN_RBUF_PUTS(buf, "#<CLASS>");
 909       break;
 910     case sen_db_obj_slot :
 911       SEN_RBUF_PUTS(buf, "#<OBJ_SLOT>");
 912       break;
 913     case sen_db_ra_slot :
 914       SEN_RBUF_PUTS(buf, "#<RA_SLOT>");
 915       break;
 916     case sen_db_ja_slot :
 917       SEN_RBUF_PUTS(buf, "#<JA_SLOT>");
 918       break;
 919     case sen_db_idx_slot :
 920       SEN_RBUF_PUTS(buf, "#<IDX_SLOT>");
 921       break;
 922     case sen_ql_list :
 923       /* todo : detect loop */
 924       if (CAR(obj) == QUOTE && ok_abbrev(CDR(obj))) {
 925         SEN_RBUF_PUTC(buf, '\'');
 926         sen_obj_inspect(ctx, CADR(obj), buf, flags);
 927       } else if (CAR(obj) == QQUOTE && ok_abbrev(CDR(obj))) {
 928         SEN_RBUF_PUTC(buf, '`');
 929         sen_obj_inspect(ctx, CADR(obj), buf, flags);
 930       } else if (CAR(obj) == UNQUOTE && ok_abbrev(CDR(obj))) {
 931         SEN_RBUF_PUTC(buf, ',');
 932         sen_obj_inspect(ctx, CADR(obj), buf, flags);
 933       } else if (CAR(obj) == UNQUOTESP && ok_abbrev(CDR(obj))) {
 934         SEN_RBUF_PUTS(buf, ",@");
 935         sen_obj_inspect(ctx, CADR(obj), buf, flags);
 936       } else {
 937         SEN_RBUF_PUTC(buf, '(');
 938         for (;;) {
 939           sen_obj_inspect(ctx, CAR(obj), buf, flags);
 940           if ((obj = CDR(obj)) && (obj != NIL)) {
 941             if (PAIRP(obj)) {
 942               SEN_RBUF_PUTC(buf, ' ');
 943             } else {
 944               SEN_RBUF_PUTS(buf, " . ");
 945               sen_obj_inspect(ctx, obj, buf, flags);
 946               SEN_RBUF_PUTC(buf, ')');
 947               break;
 948             }
 949           } else {
 950             SEN_RBUF_PUTC(buf, ')');
 951             break;
 952           }
 953         }
 954       }
 955       break;
 956     default :
 957       if (SYMBOLP(obj)) {
 958         SEN_RBUF_PUTS(buf, SYMNAME(obj));
 959       } else {
 960         SEN_RBUF_PUTS(buf, "#<?(");
 961         sen_rbuf_itoa(buf, obj->type);
 962         SEN_RBUF_PUTS(buf, ")?>");
 963       }
 964       break;
 965     }
 966   }
 967 }
 968
 969 /* ========== Routines for Evaluation Cycle ========== */
 970
 971 /* make closure. c is code. e is environment */
 972 inline static cell *
 973 mk_closure(sen_ctx *ctx, cell *c, cell *e)
 974 {
 975   cell *x;
 976   GET_CELL(ctx, c, e, x);
 977   x->type = sen_ql_closure;
 978   x->flags = SEN_OBJ_REFERER;
 979   CAR(x) = c;
 980   CDR(x) = e;
 981   return x;
 982 }
 983
 984 /* make continuation. */
 985 inline static cell *
 986 mk_continuation(sen_ctx *ctx, cell *d)
 987 {
 988   cell *x;
 989   GET_CELL(ctx, NIL, d, x);
 990   x->type = sen_ql_continuation;
 991   x->flags = SEN_OBJ_REFERER;
 992   CONT_DUMP(x) = d;
 993   return x;
 994 }
 995
 996 /* reverse list -- make new cells */
 997 inline static cell *
 998 reverse(sen_ctx *ctx, cell *a) /* a must be checked by gc */
 999 {
1000   cell *p = NIL;
1001   for ( ; PAIRP(a); a = CDR(a)) {
1002     p = CONS(CAR(a), p);
1003     if (ERRP(ctx, SEN_ERROR)) { return F; }
1004   }
1005   return p;
1006 }
1007
1008 /* reverse list --- no make new cells */
1009 inline static cell *
1010 non_alloc_rev(cell *term, cell *list)
1011 {
1012   cell *p = list, *result = term, *q;
1013   while (p != NIL) {
1014     q = CDR(p);
1015     CDR(p) = result;
1016     result = p;
1017     p = q;
1018   }
1019   return result;
1020 }
1021
1022 /* append list -- make new cells */
1023 inline static cell *
1024 append(sen_ctx *ctx, cell *a, cell *b)
1025 {
1026   cell *p = b, *q;
1027   if (a != NIL) {
1028     a = reverse(ctx, a);
1029     if (ERRP(ctx, SEN_ERROR)) { return F; }
1030     while (a != NIL) {
1031       q = CDR(a);
1032       CDR(a) = p;
1033       p = a;
1034       a = q;
1035     }
1036   }
1037   return p;
1038 }
1039
1040 /* equivalence of atoms */
1041 inline static int
1042 eqv(sen_obj *a, sen_obj *b)
1043 {
1044   if (a == b) { return 1; }
1045   if (a->type != b->type) { return 0; }
1046   switch (a->type) {
1047   case sen_ql_object :
1048     return (a->class == b->class && a->u.o.self == b->u.o.self);
1049     break;
1050   case sen_ql_bulk :
1051     return (a->u.b.size == b->u.b.size &&
1052             !memcmp(a->u.b.value, b->u.b.value, a->u.b.size));
1053     break;
1054   case sen_ql_int :
1055     return (IVALUE(a) == IVALUE(b));
1056     break;
1057   case sen_ql_float :
1058     return !islessgreater(FVALUE(a), FVALUE(b));
1059     break;
1060   case sen_ql_time :
1061     return (!memcmp(&a->u.tv, &b->u.tv, sizeof(sen_timeval)));
1062     break;
1063   default :
1064     /* todo : support other types */
1065     return 0;
1066     break;
1067   }
1068 }
1069
1070 /* true or false value macro */
1071 #define istrue(p)       ((p) != NIL && (p) != F)
1072 #define isfalse(p)      ((p) == F)
1073
1074 /* control macros for Eval_Cycle */
1075 #define s_goto(ctx,a) do {\
1076   ctx->op = (a);\
1077   return T;\
1078 } while (0)
1079
1080 #define s_save(ctx,a,b,args) (\
1081     ctx->dump = CONS(ctx->envir, CONS((args), ctx->dump)),\
1082     ctx->dump = CONS((b), ctx->dump),\
1083     ctx->dump = CONS(mk_number(ctx, (int64_t)(a)), ctx->dump))
1084
1085 #define s_return(ctx,a) do {\
1086     ctx->value = (a);\
1087     ctx->op = IVALUE(CAR(ctx->dump));\
1088     ctx->args = CADR(ctx->dump);\
1089     ctx->envir = CADDR(ctx->dump);\
1090     ctx->code = CADDDR(ctx->dump);\
1091     ctx->dump = CDDDDR(ctx->dump);\
1092     return T;\
1093 } while (0)
1094
1095 #define RTN_NIL_IF_HEAD(ctx) do {\
1096   if (((ctx)->co.mode & SEN_CTX_HEAD)) { s_goto(ctx, OP_T0LVL); }\
1097 } while (0)
1098
1099 #define RTN_NIL_IF_TAIL(ctx) do {\
1100   if (((ctx)->co.mode & SEN_CTX_TAIL)) { s_return((ctx), NIL); } else { return NIL; }\
1101 } while (0)
1102
1103 static cell *
1104 list_deep_copy(sen_ctx *ctx, cell *c) {
1105   /* NOTE: only list is copied */
1106   if (PAIRP(c)) {
1107     /* TODO: convert recursion to loop */
1108     return CONS(list_deep_copy(ctx, CAR(c)), list_deep_copy(ctx, CDR(c)));
1109   } else {
1110     return c;
1111   }
1112 }
1113
1114 static void
1115 qquote_uquotelist(sen_ctx *ctx, cell *cl, cell *pcl, int level) {
1116   /* reverse list */
1117   cell *x, *y;
1118   while (PAIRP(cl)) {
1119     x = CAR(cl);
1120     if (PAIRP(x)) {
1121       y = CAR(x);
1122       if (y == UNQUOTE) {
1123         if (level) {
1124           qquote_uquotelist(ctx, CDR(x), x, level - 1);
1125         } else {
1126           CDR(ctx->args) = CONS(cl, CDR(ctx->args)); /* save (unquote ...) cell */
1127         }
1128       } else if (y == UNQUOTESP) {
1129         if (level) {
1130           qquote_uquotelist(ctx, CDR(x), x, level - 1);
1131         } else {
1132           CDR(ctx->args) = CONS(pcl, CDR(ctx->args)); /* save pre (unquote-splicing) cell */
1133         }
1134       } else {
1135         qquote_uquotelist(ctx, x, cl, level);
1136       }
1137     } else if (x == QQUOTE) {
1138       qquote_uquotelist(ctx, CDR(cl), cl, level + 1);
1139       return;
1140     }
1141     if (!level && CADR(cl) == UNQUOTE) {
1142       CDR(ctx->args) = CONS(cl, CDR(ctx->args)); /* save (a . ,b) cell */
1143       return;
1144     }
1145     pcl = cl;
1146     cl = CDR(cl);
1147   }
1148 }
1149
1150 #define GC_THRESHOLD 1000000
1151
1152 inline static cell *
1153 opexe(sen_ctx *ctx)
1154 {
1155   register cell *x, *y;
1156   if (ctx->op == OP_T0LVL || ctx->objects->n_entries > ctx->ncells + GC_THRESHOLD) {
1157     if (ctx->gc_verbose) {
1158       sen_rbuf buf;
1159       sen_rbuf_init(&buf, 0);
1160       sen_obj_inspect(ctx, ctx->envir, &buf, SEN_OBJ_INSPECT_ESC);
1161       *buf.curr = '\0';
1162       SEN_LOG(sen_log_notice, "mgc > ncells=%d envir=<%s>", ctx->objects->n_entries, buf.head);
1163       sen_rbuf_fin(&buf);
1164     }
1165     sen_ctx_mgc(ctx);
1166     if (ctx->gc_verbose) {
1167       SEN_LOG(sen_log_notice, "mgc < ncells=%d", ctx->objects->n_entries);
1168     }
1169     ctx->ncells = ctx->objects->n_entries;
1170   }
1171   switch (ctx->op) {
1172   case OP_LOAD:    /* load */
1173     if (BULKP(CAR(ctx->args))) {
1174       struct stat st;
1175       char *fname = STRVALUE(CAR(ctx->args));
1176       if (fname && !stat(fname, &st)) {
1177         if (ctx->inbuf) { SEN_FREE(ctx->inbuf); }
1178         if ((ctx->inbuf = SEN_MALLOC(st.st_size))) {
1179           int fd;
1180           if ((fd = open(fname, O_RDONLY)) != -1) {
1181             if (read(fd, ctx->inbuf, st.st_size) == st.st_size) {
1182               SEN_RBUF_PUTS(&ctx->outbuf, "loading ");
1183               SEN_RBUF_PUTS(&ctx->outbuf, STRVALUE(CAR(ctx->args)));
1184               ctx->cur = ctx->inbuf;
1185               ctx->str_end = ctx->inbuf + st.st_size;
1186             }
1187             close(fd);
1188           }
1189           if (ctx->cur != ctx->inbuf) {
1190             SEN_FREE(ctx->inbuf);
1191             ctx->inbuf = NULL;
1192           }
1193         }
1194       }
1195     }
1196     s_goto(ctx, OP_T0LVL);
1197
1198   case OP_T0LVL:  /* top level */
1199     ctx->dump = NIL;
1200     ctx->envir = ctx->global_env;
1201     if (ctx->batchmode) {
1202       s_save(ctx, OP_T0LVL, NIL, NIL);
1203     } else {
1204       s_save(ctx, OP_VALUEPRINT, NIL, NIL);
1205     }
1206     s_save(ctx, OP_T1LVL, NIL, NIL);
1207     // if (infp == stdin) printf("hoge>\n");
1208     ctx->pht = &ctx->phs;
1209     *ctx->pht = NIL;
1210     s_goto(ctx, OP_READ);
1211
1212   case OP_T1LVL:  /* top level */
1213     // verbose check?
1214     if (ctx->phs != NIL &&
1215         !(ctx->co.mode & (SEN_CTX_HEAD|SEN_CTX_TAIL))) { RTN_NIL_IF_TAIL(ctx); }
1216     // SEN_RBUF_PUTC(&ctx->outbuf, '\n');
1217     ctx->code = ctx->value;
1218     s_goto(ctx, OP_EVAL);
1219
1220   case OP_READ:    /* read */
1221     RTN_NIL_IF_HEAD(ctx);
1222     if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1223     s_goto(ctx, OP_RDSEXPR);
1224
1225   case OP_VALUEPRINT:  /* print evalution result */
1226     ctx->args = ctx->value;
1227     s_save(ctx, OP_T0LVL, NIL, NIL);
1228     sen_obj_inspect(ctx, ctx->args, &ctx->outbuf, SEN_OBJ_INSPECT_ESC);
1229     s_return(ctx, T);
1230
1231   case OP_EVAL:    /* main part of evalution */
1232     // fixme : quick hack.
1233     if (SYMBOLP(ctx->code)) {  /* symbol */
1234       if (KEYWORDP(ctx->code)) { s_return(ctx, ctx->code); }
1235       for (x = ctx->envir; x != NIL; x = CDR(x)) {
1236         for (y = CAR(x); y != NIL; y = CDR(y))
1237           if (CAAR(y) == ctx->code)
1238             break;
1239         if (y != NIL)
1240           break;
1241       }
1242       if (x != NIL) {
1243         s_return(ctx, CDAR(y));
1244       } else {
1245         if (PROCP(ctx->code)) { s_return(ctx, ctx->code); }
1246         if (NATIVE_FUNCP(ctx->code)) { s_return(ctx, ctx->code); }
1247         QLERR("Unbounded variable %s", SYMNAME(ctx->code));
1248       }
1249     } else if (PAIRP(ctx->code)) {
1250       if (SYNTAXP(x = CAR(ctx->code))) {  /* SYNTAX */
1251         ctx->code = CDR(ctx->code);
1252         s_goto(ctx, SYNTAXNUM(x));
1253       } else {/* first, eval top element and eval arguments */
1254         s_save(ctx, OP_E0ARGS, NIL, ctx->code);
1255         ctx->code = CAR(ctx->code);
1256         // if (NATIVE_FUNCP(ctx->code)) { s_return(ctx, ctx->code); } /* call native funcs. fast */
1257         s_goto(ctx, OP_EVAL);
1258       }
1259     } else {
1260       s_return(ctx, ctx->code);
1261     }
1262
1263   case OP_E0ARGS:  /* eval arguments */
1264     if (MACROP(ctx->value)) {  /* macro expansion */
1265       s_save(ctx, OP_DOMACRO, NIL, NIL);
1266       ctx->args = CONS(ctx->code, NIL);
1267       ctx->code = ctx->value;
1268       s_goto(ctx, OP_APPLY);
1269     } else {
1270       ctx->code = CDR(ctx->code);
1271       s_goto(ctx, OP_E1ARGS);
1272     }
1273
1274   case OP_E1ARGS:  /* eval arguments */
1275     ctx->args = CONS(ctx->value, ctx->args);
1276     if (PAIRP(ctx->code)) {  /* continue */
1277       s_save(ctx, OP_E1ARGS, ctx->args, CDR(ctx->code));
1278       ctx->code = CAR(ctx->code);
1279       ctx->args = NIL;
1280       s_goto(ctx, OP_EVAL);
1281     } else {  /* end */
1282       ctx->args = non_alloc_rev(NIL, ctx->args);
1283       ctx->code = CAR(ctx->args);
1284       ctx->args = CDR(ctx->args);
1285       s_goto(ctx, OP_APPLY);
1286     }
1287
1288   case OP_APPLY:    /* apply 'code' to 'args' */
1289     if (NATIVE_FUNCP(ctx->code)) {
1290       ctx->co.func = ctx->code->u.o.func;
1291       s_goto(ctx, OP_NATIVE);
1292     } else if (PROCP(ctx->code)) {
1293       s_goto(ctx, PROCNUM(ctx->code));  /* PROCEDURE */
1294     } else if (CLOSUREP(ctx->code)) {  /* CLOSURE */
1295       /* make environment */
1296       ctx->envir = CONS(NIL, CLOSURE_ENV(ctx->code));
1297       for (x = CAR(CLOSURE_CODE(ctx->code)), y = ctx->args;
1298            PAIRP(x); x = CDR(x), y = CDR(y)) {
1299         if (y == NIL) {
1300           QLERR("Few arguments");
1301         } else {
1302           CAR(ctx->envir) = CONS(CONS(CAR(x), CAR(y)), CAR(ctx->envir));
1303         }
1304       }
1305       if (x == NIL) {
1306         /*--
1307          * if (y != NIL) {
1308          *   QLERR("Many arguments");
1309          * }
1310          */
1311       } else if (SYMBOLP(x))
1312         CAR(ctx->envir) = CONS(CONS(x, y), CAR(ctx->envir));
1313       else {
1314         QLERR("Syntax error in closure");
1315       }
1316       ctx->code = CDR(CLOSURE_CODE(ctx->code));
1317       ctx->args = NIL;
1318       s_goto(ctx, OP_BEGIN);
1319     } else if (CONTINUATIONP(ctx->code)) {  /* CONTINUATION */
1320       ctx->dump = CONT_DUMP(ctx->code);
1321       s_return(ctx, ctx->args != NIL ? CAR(ctx->args) : NIL);
1322     } else {
1323       QLERR("Illegal function");
1324     }
1325
1326   case OP_DOMACRO:  /* do macro */
1327     ctx->code = ctx->value;
1328     s_goto(ctx, OP_EVAL);
1329
1330   case OP_LAMBDA:  /* lambda */
1331     s_return(ctx, mk_closure(ctx, ctx->code, ctx->envir));
1332
1333   case OP_QUOTE:    /* quote */
1334     s_return(ctx, CAR(ctx->code));
1335
1336   case OP_DEF0:  /* define */
1337     if (PAIRP(CAR(ctx->code))) {
1338       x = CAAR(ctx->code);
1339       ctx->code = CONS(LAMBDA, CONS(CDAR(ctx->code), CDR(ctx->code)));
1340     } else {
1341       x = CAR(ctx->code);
1342       ctx->code = CADR(ctx->code);
1343     }
1344     if (!SYMBOLP(x)) {
1345       QLERR("Variable is not symbol");
1346     }
1347     s_save(ctx, OP_DEF1, NIL, x);
1348     s_goto(ctx, OP_EVAL);
1349
1350   case OP_DEF1:  /* define */
1351     for (x = CAR(ctx->envir); x != NIL; x = CDR(x))
1352       if (CAAR(x) == ctx->code)
1353         break;
1354     if (x != NIL)
1355       CDAR(x) = ctx->value;
1356     else
1357       CAR(ctx->envir) = CONS(CONS(ctx->code, ctx->value), CAR(ctx->envir));
1358     s_return(ctx, ctx->code);
1359
1360   case OP_SET0:    /* set! */
1361     s_save(ctx, OP_SET1, NIL, CAR(ctx->code));
1362     ctx->code = CADR(ctx->code);
1363     s_goto(ctx, OP_EVAL);
1364
1365   case OP_SET1:    /* set! */
1366     for (x = ctx->envir; x != NIL; x = CDR(x)) {
1367       for (y = CAR(x); y != NIL; y = CDR(y))
1368         if (CAAR(y) == ctx->code)
1369           break;
1370       if (y != NIL)
1371         break;
1372     }
1373     if (x != NIL) {
1374       CDAR(y) = ctx->value;
1375       s_return(ctx, ctx->value);
1376     } else {
1377       QLERR("Unbounded variable %s", SYMBOLP(ctx->code) ? SYMNAME(ctx->code) : "");
1378     }
1379
1380   case OP_BEGIN:    /* begin */
1381     if (!PAIRP(ctx->code)) {
1382       s_return(ctx, ctx->code);
1383     }
1384     if (CDR(ctx->code) != NIL) {
1385       s_save(ctx, OP_BEGIN, NIL, CDR(ctx->code));
1386     }
1387     ctx->code = CAR(ctx->code);
1388     s_goto(ctx, OP_EVAL);
1389
1390   case OP_IF0:    /* if */
1391     s_save(ctx, OP_IF1, NIL, CDR(ctx->code));
1392     ctx->code = CAR(ctx->code);
1393     s_goto(ctx, OP_EVAL);
1394
1395   case OP_IF1:    /* if */
1396     if (istrue(ctx->value))
1397       ctx->code = CAR(ctx->code);
1398     else
1399       ctx->code = CADR(ctx->code);  /* (if #f 1) ==> () because
1400              * CAR(NIL) = NIL */
1401     s_goto(ctx, OP_EVAL);
1402
1403   case OP_LET0:    /* let */
1404     ctx->args = NIL;
1405     ctx->value = ctx->code;
1406     ctx->code = SYMBOLP(CAR(ctx->code)) ? CADR(ctx->code) : CAR(ctx->code);
1407     s_goto(ctx, OP_LET1);
1408
1409   case OP_LET1:    /* let (caluculate parameters) */
1410     ctx->args = CONS(ctx->value, ctx->args);
1411     if (PAIRP(ctx->code)) {  /* continue */
1412       QLASSERT(LISTP(CAR(ctx->code)) && LISTP(CDAR(ctx->code)));
1413       s_save(ctx, OP_LET1, ctx->args, CDR(ctx->code));
1414       ctx->code = CADAR(ctx->code);
1415       ctx->args = NIL;
1416       s_goto(ctx, OP_EVAL);
1417     } else {  /* end */
1418       ctx->args = non_alloc_rev(NIL, ctx->args);
1419       ctx->code = CAR(ctx->args);
1420       ctx->args = CDR(ctx->args);
1421       s_goto(ctx, OP_LET2);
1422     }
1423
1424   case OP_LET2:    /* let */
1425     ctx->envir = CONS(NIL, ctx->envir);
1426     for (x = SYMBOLP(CAR(ctx->code)) ? CADR(ctx->code) : CAR(ctx->code), y = ctx->args;
1427          y != NIL; x = CDR(x), y = CDR(y))
1428       CAR(ctx->envir) = CONS(CONS(CAAR(x), CAR(y)), CAR(ctx->envir));
1429     if (SYMBOLP(CAR(ctx->code))) {  /* named let */
1430       for (x = CADR(ctx->code), ctx->args = NIL; PAIRP(x); x = CDR(x))
1431         ctx->args = CONS(CAAR(x), ctx->args);
1432       x = mk_closure(ctx, CONS(non_alloc_rev(NIL, ctx->args), CDDR(ctx->code)),
1433                      ctx->envir);
1434       CAR(ctx->envir) = CONS(CONS(CAR(ctx->code), x), CAR(ctx->envir));
1435       ctx->code = CDDR(ctx->code);
1436       ctx->args = NIL;
1437     } else {
1438       ctx->code = CDR(ctx->code);
1439       ctx->args = NIL;
1440     }
1441     s_goto(ctx, OP_BEGIN);
1442
1443   case OP_LET0AST:  /* let* */
1444     if (CAR(ctx->code) == NIL) {
1445       ctx->envir = CONS(NIL, ctx->envir);
1446       ctx->code = CDR(ctx->code);
1447       s_goto(ctx, OP_BEGIN);
1448     }
1449     s_save(ctx, OP_LET1AST, CDR(ctx->code), CAR(ctx->code));
1450     QLASSERT(LISTP(CAR(ctx->code)) &&
1451              LISTP(CAAR(ctx->code)) && LISTP((CDR(CAAR(ctx->code)))));
1452     ctx->code = CADAAR(ctx->code);
1453     s_goto(ctx, OP_EVAL);
1454
1455   case OP_LET1AST:  /* let* (make new frame) */
1456     ctx->envir = CONS(NIL, ctx->envir);
1457     s_goto(ctx, OP_LET2AST);
1458
1459   case OP_LET2AST:  /* let* (caluculate parameters) */
1460     CAR(ctx->envir) = CONS(CONS(CAAR(ctx->code), ctx->value), CAR(ctx->envir));
1461     ctx->code = CDR(ctx->code);
1462     if (PAIRP(ctx->code)) {  /* continue */
1463       QLASSERT(LISTP(CAR(ctx->code)) && LISTP(CDAR(ctx->code)));
1464       s_save(ctx, OP_LET2AST, ctx->args, ctx->code);
1465       ctx->code = CADAR(ctx->code);
1466       ctx->args = NIL;
1467       s_goto(ctx, OP_EVAL);
1468     } else {  /* end */
1469       ctx->code = ctx->args;
1470       ctx->args = NIL;
1471       s_goto(ctx, OP_BEGIN);
1472     }
1473
1474   case OP_LET0REC:  /* letrec */
1475     ctx->envir = CONS(NIL, ctx->envir);
1476     ctx->args = NIL;
1477     ctx->value = ctx->code;
1478     ctx->code = CAR(ctx->code);
1479     s_goto(ctx, OP_LET1REC);
1480
1481   case OP_LET1REC:  /* letrec (caluculate parameters) */
1482     ctx->args = CONS(ctx->value, ctx->args);
1483     if (PAIRP(ctx->code)) {  /* continue */
1484       QLASSERT(LISTP(CAR(ctx->code)) && LISTP(CDAR(ctx->code)));
1485       s_save(ctx, OP_LET1REC, ctx->args, CDR(ctx->code));
1486       ctx->code = CADAR(ctx->code);
1487       ctx->args = NIL;
1488       s_goto(ctx, OP_EVAL);
1489     } else {  /* end */
1490       ctx->args = non_alloc_rev(NIL, ctx->args);
1491       ctx->code = CAR(ctx->args);
1492       ctx->args = CDR(ctx->args);
1493       s_goto(ctx, OP_LET2REC);
1494     }
1495
1496   case OP_LET2REC:  /* letrec */
1497     for (x = CAR(ctx->code), y = ctx->args; y != NIL; x = CDR(x), y = CDR(y))
1498       CAR(ctx->envir) = CONS(CONS(CAAR(x), CAR(y)), CAR(ctx->envir));
1499     ctx->code = CDR(ctx->code);
1500     ctx->args = NIL;
1501     s_goto(ctx, OP_BEGIN);
1502
1503   case OP_COND0:    /* cond */
1504     if (!PAIRP(ctx->code)) {
1505       QLERR("Syntax error in cond");
1506     }
1507     s_save(ctx, OP_COND1, NIL, ctx->code);
1508     ctx->code = CAAR(ctx->code);
1509     s_goto(ctx, OP_EVAL);
1510
1511   case OP_COND1:    /* cond */
1512     if (istrue(ctx->value)) {
1513       if ((ctx->code = CDAR(ctx->code)) == NIL) {
1514         s_return(ctx, ctx->value);
1515       }
1516       s_goto(ctx, OP_BEGIN);
1517     } else {
1518       if ((ctx->code = CDR(ctx->code)) == NIL) {
1519         s_return(ctx, NIL);
1520       } else {
1521         s_save(ctx, OP_COND1, NIL, ctx->code);
1522         ctx->code = CAAR(ctx->code);
1523         s_goto(ctx, OP_EVAL);
1524       }
1525     }
1526
1527   case OP_DELAY:    /* delay */
1528     x = mk_closure(ctx, CONS(NIL, ctx->code), ctx->envir);
1529     if (ERRP(ctx, SEN_ERROR)) { return F; }
1530     SETPROMISE(x);
1531     s_return(ctx, x);
1532
1533   case OP_AND0:    /* and */
1534     if (ctx->code == NIL) {
1535       s_return(ctx, T);
1536     }
1537     s_save(ctx, OP_AND1, NIL, CDR(ctx->code));
1538     ctx->code = CAR(ctx->code);
1539     s_goto(ctx, OP_EVAL);
1540
1541   case OP_AND1:    /* and */
1542     if (isfalse(ctx->value)) {
1543       s_return(ctx, ctx->value);
1544     } else if (ctx->code == NIL) {
1545       s_return(ctx, ctx->value);
1546     } else {
1547       s_save(ctx, OP_AND1, NIL, CDR(ctx->code));
1548       ctx->code = CAR(ctx->code);
1549       s_goto(ctx, OP_EVAL);
1550     }
1551
1552   case OP_OR0:    /* or */
1553     if (ctx->code == NIL) {
1554       s_return(ctx, F);
1555     }
1556     s_save(ctx, OP_OR1, NIL, CDR(ctx->code));
1557     ctx->code = CAR(ctx->code);
1558     s_goto(ctx, OP_EVAL);
1559
1560   case OP_OR1:    /* or */
1561     if (istrue(ctx->value)) {
1562       s_return(ctx, ctx->value);
1563     } else if (ctx->code == NIL) {
1564       s_return(ctx, ctx->value);
1565     } else {
1566       s_save(ctx, OP_OR1, NIL, CDR(ctx->code));
1567       ctx->code = CAR(ctx->code);
1568       s_goto(ctx, OP_EVAL);
1569     }
1570
1571   case OP_C0STREAM:  /* cons-stream */
1572     s_save(ctx, OP_C1STREAM, NIL, CDR(ctx->code));
1573     ctx->code = CAR(ctx->code);
1574     s_goto(ctx, OP_EVAL);
1575
1576   case OP_C1STREAM:  /* cons-stream */
1577     ctx->args = ctx->value;  /* save ctx->value to register ctx->args for gc */
1578     x = mk_closure(ctx, CONS(NIL, ctx->code), ctx->envir);
1579     if (ERRP(ctx, SEN_ERROR)) { return F; }
1580     SETPROMISE(x);
1581     s_return(ctx, CONS(ctx->args, x));
1582
1583   case OP_0MACRO:  /* macro */
1584     x = CAR(ctx->code);
1585     ctx->code = CADR(ctx->code);
1586     if (!SYMBOLP(x)) {
1587       QLERR("Variable is not symbol");
1588     }
1589     s_save(ctx, OP_1MACRO, NIL, x);
1590     s_goto(ctx, OP_EVAL);
1591
1592   case OP_1MACRO:  /* macro */
1593     ctx->value->flags |= SEN_OBJ_MACRO;
1594     for (x = CAR(ctx->envir); x != NIL; x = CDR(x))
1595       if (CAAR(x) == ctx->code)
1596         break;
1597     if (x != NIL)
1598       CDAR(x) = ctx->value;
1599     else
1600       CAR(ctx->envir) = CONS(CONS(ctx->code, ctx->value), CAR(ctx->envir));
1601     s_return(ctx, ctx->code);
1602
1603   case OP_CASE0:    /* case */
1604     s_save(ctx, OP_CASE1, NIL, CDR(ctx->code));
1605     ctx->code = CAR(ctx->code);
1606     s_goto(ctx, OP_EVAL);
1607
1608   case OP_CASE1:    /* case */
1609     for (x = ctx->code; x != NIL; x = CDR(x)) {
1610       if (!PAIRP(y = CAAR(x)))
1611         break;
1612       for ( ; y != NIL; y = CDR(y))
1613         if (eqv(CAR(y), ctx->value))
1614           break;
1615       if (y != NIL)
1616         break;
1617     }
1618     if (x != NIL) {
1619       if (PAIRP(CAAR(x))) {
1620         ctx->code = CDAR(x);
1621         s_goto(ctx, OP_BEGIN);
1622       } else {/* else */
1623         s_save(ctx, OP_CASE2, NIL, CDAR(x));
1624         ctx->code = CAAR(x);
1625         s_goto(ctx, OP_EVAL);
1626       }
1627     } else {
1628       s_return(ctx, NIL);
1629     }
1630
1631   case OP_CASE2:    /* case */
1632     if (istrue(ctx->value)) {
1633       s_goto(ctx, OP_BEGIN);
1634     } else {
1635       s_return(ctx, NIL);
1636     }
1637   case OP_PAPPLY:  /* apply */
1638     ctx->code = CAR(ctx->args);
1639     ctx->args = CADR(ctx->args);
1640     s_goto(ctx, OP_APPLY);
1641
1642   case OP_PEVAL:  /* eval */
1643     ctx->code = CAR(ctx->args);
1644     ctx->args = NIL;
1645     s_goto(ctx, OP_EVAL);
1646
1647   case OP_CONTINUATION:  /* call-with-current-continuation */
1648     ctx->code = CAR(ctx->args);
1649     ctx->args = CONS(mk_continuation(ctx, ctx->dump), NIL);
1650     s_goto(ctx, OP_APPLY);
1651
1652   case OP_SETCAR:  /* set-car! */
1653     if (PAIRP(CAR(ctx->args))) {
1654       CAAR(ctx->args) = CADR(ctx->args);
1655       s_return(ctx, CAR(ctx->args));
1656     } else {
1657       QLERR("Unable to set-car! for non-cons cell");
1658     }
1659
1660   case OP_SETCDR:  /* set-cdr! */
1661     if (PAIRP(CAR(ctx->args))) {
1662       CDAR(ctx->args) = CADR(ctx->args);
1663       s_return(ctx, CAR(ctx->args));
1664     } else {
1665       QLERR("Unable to set-cdr! for non-cons cell");
1666     }
1667
1668   case OP_FORCE:    /* force */
1669     ctx->code = CAR(ctx->args);
1670     if (PROMISEP(ctx->code)) {
1671       ctx->args = NIL;
1672       s_goto(ctx, OP_APPLY);
1673     } else {
1674       s_return(ctx, ctx->code);
1675     }
1676
1677   case OP_ERR0:  /* error */
1678     SEN_RBUF_PUTS(&ctx->outbuf, "*** ERROR: ");
1679     SEN_RBUF_PUTS(&ctx->outbuf, ctx->errbuf);
1680     SEN_RBUF_PUTC(&ctx->outbuf, '\n');
1681     ctx->args = NIL;
1682     s_goto(ctx, OP_T0LVL);
1683
1684   case OP_ERR1:  /* error */
1685     SEN_RBUF_PUTS(&ctx->outbuf, "*** ERROR:");
1686     while (ctx->args != NIL) {
1687       SEN_RBUF_PUTC(&ctx->outbuf, ' ');
1688       sen_obj_inspect(ctx, CAR(ctx->args), &ctx->outbuf, SEN_OBJ_INSPECT_ESC);
1689       ctx->args = CDR(ctx->args);
1690     }
1691     SEN_RBUF_PUTC(&ctx->outbuf, '\n');
1692     s_goto(ctx, OP_T0LVL);
1693
1694   case OP_PUT:    /* put */
1695     if (!HASPROP(CAR(ctx->args)) || !HASPROP(CADR(ctx->args))) {
1696       QLERR("Illegal use of put");
1697     }
1698     for (x = SYMPROP(CAR(ctx->args)), y = CADR(ctx->args); x != NIL; x = CDR(x))
1699       if (CAAR(x) == y)
1700         break;
1701     if (x != NIL)
1702       CDAR(x) = CADDR(ctx->args);
1703     else
1704       SYMPROP(CAR(ctx->args)) = CONS(CONS(y, CADDR(ctx->args)),
1705               SYMPROP(CAR(ctx->args)));
1706     s_return(ctx, T);
1707
1708   case OP_GET:    /* get */
1709     if (!HASPROP(CAR(ctx->args)) || !HASPROP(CADR(ctx->args))) {
1710       QLERR("Illegal use of get");
1711     }
1712     for (x = SYMPROP(CAR(ctx->args)), y = CADR(ctx->args); x != NIL; x = CDR(x))
1713       if (CAAR(x) == y)
1714         break;
1715     if (x != NIL) {
1716       s_return(ctx, CDAR(x));
1717     } else {
1718       s_return(ctx, NIL);
1719     }
1720
1721   case OP_SDOWN:   /* shutdown */
1722     SEN_LOG(sen_log_notice, "shutting down..");
1723     sen_gctx.stat = SEN_CTX_QUIT;
1724     s_goto(ctx, OP_QUIT);
1725
1726   case OP_RDSEXPR:
1727     {
1728       char tok, *str;
1729       unsigned len;
1730       RTN_NIL_IF_HEAD(ctx);
1731       switch (ctx->tok) {
1732       case TOK_COMMENT:
1733         skipline(ctx);
1734         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1735         s_goto(ctx, OP_RDSEXPR);
1736       case TOK_LPAREN:
1737         if ((tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1738         ctx->tok = tok;
1739         if (ctx->tok == TOK_RPAREN) {
1740           s_return(ctx, NIL);
1741         } else if (ctx->tok == TOK_DOT) {
1742           QLERR("syntax error: illegal dot expression");
1743         } else {
1744           s_save(ctx, OP_RDLIST, NIL, NIL);
1745           s_goto(ctx, OP_RDSEXPR);
1746         }
1747       case TOK_QUOTE:
1748         s_save(ctx, OP_RDQUOTE, NIL, NIL);
1749         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1750         s_goto(ctx, OP_RDSEXPR);
1751       case TOK_BQUOTE:
1752         s_save(ctx, OP_RDQQUOTE, NIL, NIL);
1753         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1754         s_goto(ctx, OP_RDSEXPR);
1755       case TOK_COMMA:
1756         s_save(ctx, OP_RDUNQUOTE, NIL, NIL);
1757         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1758         s_goto(ctx, OP_RDSEXPR);
1759       case TOK_ATMARK:
1760         s_save(ctx, OP_RDUQTSP, NIL, NIL);
1761         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1762         s_goto(ctx, OP_RDSEXPR);
1763       case TOK_ATOM:
1764         if (readstr(ctx, &str, &len) == TOK_EOS) { ctx->tok = TOK_EOS; RTN_NIL_IF_TAIL(ctx); }
1765         s_return(ctx, mk_atom(ctx, str, len, NIL));
1766       case TOK_DQUOTE:
1767         if (readstrexp(ctx, &str, &len) == TOK_EOS) {
1768           QLERR("unterminated string");
1769         }
1770         s_return(ctx, sen_ql_mk_string(ctx, str, len));
1771       case TOK_SHARP:
1772         if ((readstr(ctx, &str, &len) == TOK_EOS) ||
1773             (x = mk_const(ctx, str, len)) == NIL) {
1774           QLERR("Undefined sharp expression");
1775         } else {
1776           s_return(ctx, x);
1777         }
1778       case TOK_EOS :
1779         if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1780         s_goto(ctx, OP_RDSEXPR);
1781       case TOK_QUESTION:
1782         {
1783           cell *o, *p;
1784           SEN_OBJ_NEW(ctx, o);
1785           p = CONS(o, NIL);
1786           o->type = sen_ql_bulk;
1787           o->flags = 0;
1788           o->u.b.size = 1;
1789           o->u.b.value = "?";
1790           *ctx->pht = p;
1791           ctx->pht = &CDR(p);
1792           s_return(ctx, o);
1793         }
1794       default:
1795         QLERR("syntax error: illegal token");
1796       }
1797     }
1798     break;
1799
1800   case OP_RDLIST:
1801     RTN_NIL_IF_HEAD(ctx);
1802     if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1803     if (ctx->tok == TOK_COMMENT) {
1804       skipline(ctx);
1805       s_goto(ctx, OP_RDLIST);
1806     }
1807     ctx->args = CONS(ctx->value, ctx->args);
1808     if (ctx->tok == TOK_RPAREN) {
1809       cell *v = non_alloc_rev(NIL, ctx->args);
1810       if (ctx->cur < ctx->str_end && *ctx->cur == '.') {
1811         char *str = NULL;
1812         unsigned len = 0;
1813         if (readstr(ctx, &str, &len) != TOK_ATOM) { /* error */ }
1814         s_return(ctx, mk_atom(ctx, str, len, v));
1815       } else {
1816         s_return(ctx, v);
1817       }
1818     } else if (ctx->tok == TOK_DOT) {
1819       s_save(ctx, OP_RDDOT, ctx->args, NIL);
1820       if ((ctx->tok = token(ctx)) == TOK_EOS) {
1821         ctx->op = OP_RDSEXPR; RTN_NIL_IF_TAIL(ctx);
1822       }
1823       s_goto(ctx, OP_RDSEXPR);
1824     } else {
1825       s_save(ctx, OP_RDLIST, ctx->args, NIL);;
1826       s_goto(ctx, OP_RDSEXPR);
1827     }
1828
1829   case OP_RDDOT:
1830     RTN_NIL_IF_HEAD(ctx);
1831     if ((ctx->tok = token(ctx)) == TOK_EOS) { RTN_NIL_IF_TAIL(ctx); }
1832     if (ctx->tok != TOK_RPAREN) {
1833       QLERR("syntax error: illegal dot expression");
1834     } else {
1835       cell *v = non_alloc_rev(ctx->value, ctx->args);
1836       if (ctx->cur < ctx->str_end && *ctx->cur == '.') {
1837         char *str = NULL;
1838         unsigned len = 0;
1839         if (readstr(ctx, &str, &len) != TOK_ATOM) { /* error */ }
1840         s_return(ctx, mk_atom(ctx, str, len, v));
1841       } else {
1842         s_return(ctx, v);
1843       }
1844     }
1845
1846   case OP_RDQUOTE:
1847     s_return(ctx, CONS(QUOTE, CONS(ctx->value, NIL)));
1848
1849   case OP_RDQQUOTE:
1850     s_return(ctx, CONS(QQUOTE, CONS(ctx->value, NIL)));
1851
1852   case OP_RDUNQUOTE:
1853     s_return(ctx, CONS(UNQUOTE, CONS(ctx->value, NIL)));
1854
1855   case OP_RDUQTSP:
1856     s_return(ctx, CONS(UNQUOTESP, CONS(ctx->value, NIL)));
1857
1858   case OP_NATIVE:
1859     s_return(ctx, ctx->value);
1860   case OP_QQUOTE0:
1861     ctx->code = list_deep_copy(ctx, ctx->code);
1862     ctx->args = CONS(ctx->code, NIL);
1863     qquote_uquotelist(ctx, ctx->code, ctx->code, 0);
1864     ctx->code = CDR(ctx->args);
1865     s_goto(ctx, OP_QQUOTE1);
1866   case OP_QQUOTE1:
1867     while (PAIRP(ctx->code)) {
1868       x = CAR(ctx->code);
1869       if (PAIRP(x) && LISTP(CDR(x))) {
1870         s_save(ctx, OP_QQUOTE2, ctx->args, ctx->code);
1871         y = CADR(x);
1872         if (y == UNQUOTE) {
1873           QLASSERT(LISTP(CDDR(x)));
1874           ctx->code = CADDR(x);
1875         } else if (CAR(y) == UNQUOTESP) {
1876           QLASSERT(LISTP(CDR(y)));
1877           ctx->code = CADR(y);
1878         } else {
1879           y = CAR(x);
1880           if (CAR(y) == UNQUOTE) {
1881             ctx->code = CADR(y);
1882           } else if (CAAR(y) == UNQUOTESP) {
1883             ctx->code = CADAR(y);
1884           } else {
1885             /* error */
1886           }
1887         }
1888         s_goto(ctx, OP_EVAL);
1889       }
1890       ctx->code = CDR(ctx->code);
1891     }
1892     s_return(ctx, CAAR(ctx->args));
1893   case OP_QQUOTE2:
1894     x = CAR(ctx->code);
1895     y = CADR(x);
1896     if (y == UNQUOTE) {
1897       CDR(x) = ctx->value;
1898     } else if (CAR(y) == UNQUOTESP) {
1899       if (ctx->value == NIL) {
1900         CDR(x) = CDDR(x);
1901       } else if (!PAIRP(ctx->value) ) {
1902         /* error */
1903       } else {
1904         ctx->value = list_deep_copy(ctx, ctx->value);
1905         for (y = ctx->value; CDR(y) != NIL; y = CDR(y)) {}
1906         CDR(y) = CDDR(x);
1907         CDR(x) = ctx->value;
1908       }
1909     } else {
1910       y = CAAR(x);
1911       if (y == UNQUOTE) {
1912         CAR(x) = ctx->value;
1913       } else if (CAR(y) == UNQUOTESP) {
1914         if (ctx->value == NIL) {
1915           CAR(x) = CDAR(x);
1916         } else if (!PAIRP(ctx->value) ) {
1917           /* error */
1918         } else {
1919           ctx->value = list_deep_copy(ctx, ctx->value);
1920           for (y = ctx->value; CDR(y) != NIL; y = CDR(y)) {}
1921           CDR(y) = CDAR(x);
1922           CAR(x) = ctx->value;
1923         }
1924       } else {
1925         /* error */
1926       }
1927     }
1928     ctx->code = CDR(ctx->code);
1929     s_goto(ctx, OP_QQUOTE1);
1930   }
1931   SEN_LOG(sen_log_error, "illegal op (%d)", ctx->op);
1932   return NIL;
1933 }
1934
1935 /* kernel of this intepreter */
1936 inline static void
1937 Eval_Cycle(sen_ctx *ctx)
1938 {
1939   ctx->co.func = NULL;
1940   ctx->co.last = 0;
1941   while (opexe(ctx) != NIL) {
1942     switch (ctx->op) {
1943     case OP_NATIVE :
1944       ctx->stat = SEN_QL_NATIVE;
1945       return;
1946     case OP_T0LVL :
1947       ctx->stat = SEN_QL_TOPLEVEL;
1948       return;
1949     case OP_T1LVL :
1950       ctx->stat = (ctx->phs != NIL) ? SEN_QL_WAIT_ARG : SEN_QL_EVAL;
1951       return;
1952     case OP_QUIT :
1953       ctx->stat = SEN_QL_QUITTING;
1954       return;
1955     default :
1956       break;
1957     }
1958     if (ERRP(ctx, SEN_ERROR)) { return; }
1959   }
1960   ctx->stat = SEN_QL_WAIT_EXPR;
1961 }
1962
1963 sen_obj *
1964 sen_ql_eval(sen_ctx *ctx, sen_obj *code, sen_obj *objs)
1965 {
1966   sen_ql_co co;
1967   uint8_t op = ctx->op;
1968   uint8_t stat = ctx->stat;
1969   uint8_t feed_mode = ctx->feed_mode;
1970   sen_obj *o, *code_ = ctx->code;
1971   o = CONS(objs, ctx->envir);
1972   memcpy(&co, &ctx->co, sizeof(sen_ql_co));
1973   s_save(ctx, OP_QUIT, ctx->args, o);
1974   ctx->op = OP_EVAL;
1975   ctx->stat = SEN_QL_EVAL;
1976   ctx->code = code;
1977   ctx->feed_mode = sen_ql_atonce;
1978   sen_ql_feed(ctx, NULL, 0, 0);
1979   ctx->feed_mode = feed_mode;
1980   ctx->stat = stat;
1981   ctx->op = op;
1982   ctx->envir = CDR(o);
1983   ctx->code = code_;
1984   memcpy(&ctx->co, &co, sizeof(sen_ql_co));
1985   return ctx->value;
1986 }
1987
1988 /* ========== native functions ========== */
1989
1990 #define s_retbool(tf)  do { return (tf) ? T : F; } while (0)
1991
1992 #define do_op(x,y,op) do {\
1993   switch ((x)->type) {\
1994   case sen_ql_int :\
1995     switch ((y)->type) {\
1996     case sen_ql_int :\
1997       IVALUE(x) = IVALUE(x) op IVALUE(y);\
1998       break;\
1999     case sen_ql_float :\
2000       SETFLOAT(x, ((double) IVALUE(x)) op FVALUE(y));\
2001       break;\
2002     default :\
2003       if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }\
2004       IVALUE(x) = IVALUE(x) op IVALUE(y);\
2005     }\
2006     break;\
2007   case sen_ql_float :\
2008     switch ((y)->type) {\
2009     case sen_ql_int :\
2010       FVALUE(x) = FVALUE(x) op IVALUE(y);\
2011       break;\
2012     case sen_ql_float :\
2013       FVALUE(x) = FVALUE(x) op FVALUE(y);\
2014       break;\
2015     default :\
2016       if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }\
2017       FVALUE(x) = FVALUE(x) op IVALUE(y);\
2018     }\
2019     break;\
2020   default :\
2021     QLERR("can't convert into numeric");\
2022   }\
2023 } while (0)
2024
2025 #define do_compare(x,y,r,op) do {\
2026   switch (x->type) {\
2027   case sen_ql_int :\
2028     switch (y->type) {\
2029     case sen_ql_int :\
2030       r = (IVALUE(x) op IVALUE(y));\
2031       break;\
2032     case sen_ql_float :\
2033       r = (IVALUE(x) op FVALUE(y));\
2034       break;\
2035     default :\
2036       if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }\
2037       r = (IVALUE(x) op IVALUE(y));\
2038     }\
2039     break;\
2040   case sen_ql_float :\
2041     switch (y->type) {\
2042     case sen_ql_int :\
2043       r = (FVALUE(x) op IVALUE(y));\
2044       break;\
2045     case sen_ql_float :\
2046       r = (FVALUE(x) op FVALUE(y));\
2047       break;\
2048     default :\
2049       if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }\
2050       r = (FVALUE(x) op IVALUE(y));\
2051     }\
2052     break;\
2053   case sen_ql_bulk :\
2054     if (y->type == sen_ql_bulk) {\
2055       int r_;\
2056       uint32_t la = x->u.b.size, lb = y->u.b.size;\
2057       if (la > lb) {\
2058         if (!(r_ = memcmp(x->u.b.value, y->u.b.value, lb))) {\
2059           r_ = 1;\
2060         }\
2061       } else {\
2062         if (!(r_ = memcmp(x->u.b.value, y->u.b.value, la))) {\
2063           r_ = la == lb ? 0 : -1;\
2064         }\
2065       }\
2066       r = (r_ op 0);\
2067     } else {\
2068       QLERR("can't compare");\
2069     }\
2070     break;\
2071   case sen_ql_time :\
2072     if (y->type == sen_ql_time) {\
2073       if (x->u.tv.tv_sec != y->u.tv.tv_sec) {\
2074         r = (x->u.tv.tv_sec op y->u.tv.tv_sec);\
2075       } else {\
2076         r = (x->u.tv.tv_usec op y->u.tv.tv_usec);\
2077       }\
2078     } else {\
2079       QLERR("can't compare");\
2080     }\
2081   default :\
2082     r = (memcmp(&x->u.tv, &y->u.tv, sizeof(sen_timeval)) op 0);\
2083   }\
2084 } while (0)
2085
2086 #define time_op(x,y,v,op) {\
2087   switch (y->type) {\
2088   case sen_ql_time :\
2089     {\
2090       double dv= x->u.tv.tv_sec op y->u.tv.tv_sec;\
2091       dv += (x->u.tv.tv_usec op y->u.tv.tv_usec) / 1000000.0;\
2092       SETFLOAT(v, dv);\
2093     }\
2094     break;\
2095   case sen_ql_int :\
2096     {\
2097       sen_timeval tv;\
2098       int64_t sec = x->u.tv.tv_sec op IVALUE(y);\
2099       if (sec < INT32_MIN || INT32_MAX < sec) { QLERR("time val overflow"); }\
2100       tv.tv_sec = (int)sec;\
2101       tv.tv_usec = x->u.tv.tv_usec;\
2102       SETTIME(v, &tv);\
2103     }\
2104     break;\
2105   case sen_ql_float :\
2106     {\
2107       sen_timeval tv;\
2108       double sec = x->u.tv.tv_sec op (int)FVALUE(y);\
2109       int32_t usec = x->u.tv.tv_usec op (int)((FVALUE(y) - (int)FVALUE(y)) * 1000000);\
2110       if (sec < INT32_MIN || INT32_MAX < sec) { QLERR("time val overflow"); }\
2111       tv.tv_sec = (int)sec;\
2112       if (usec < 0) {\
2113         tv.tv_sec--;\
2114         usec += 1000000;\
2115       } else if (usec >= 1000000) {\
2116         tv.tv_sec++;\
2117         usec -= 1000000;\
2118       }\
2119       tv.tv_usec = usec;\
2120       SETTIME(v, &tv);\
2121     }\
2122     break;\
2123   default :\
2124     QLERR("can't convert into numeric value");\
2125     break;\
2126   }\
2127 } while (0)
2128
2129 static sen_obj *
2130 nf_add(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2131 {
2132   register cell *x, *v;
2133   if (!PAIRP(args)) { QLERR("list required"); }
2134   switch (CAR(args)->type) {
2135   case sen_ql_bulk :
2136     {
2137       sen_rbuf buf;
2138       sen_rbuf_init(&buf, 0);
2139       while (PAIRP(args)) {
2140         POP(x, args);
2141         sen_obj_inspect(ctx, x, &buf, 0);
2142       }
2143       SEN_RBUF2OBJ(ctx, &buf, v);
2144     }
2145     break;
2146   case sen_ql_time :
2147     if (PAIRP(CDR(args)) && NUMBERP(CADR(args))) {
2148       SEN_OBJ_NEW(ctx, v);
2149       time_op(CAR(args), CADR(args), v, +);
2150     } else {
2151       QLERR("can't convert into numeric value");
2152     }
2153     break;
2154   default :
2155     v = mk_number(ctx, 0);
2156     while (PAIRP(args)) {
2157       POP(x, args);
2158       do_op(v, x, +);
2159     }
2160     break;
2161   }
2162   return v;
2163 }
2164
2165 static sen_obj *
2166 nf_sub(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2167 {
2168   register cell *v = mk_number(ctx, 0);
2169   register cell *x;
2170   if (PAIRP(args) && CDR(args) != NIL) {
2171     if (CAR(args)->type == sen_ql_time) {
2172       time_op(CAR(args), CADR(args), v, -);
2173       return v;
2174     }
2175     POP(x, args);
2176     do_op(v, x, +);
2177   }
2178   while (PAIRP(args)) {
2179     POP(x, args);
2180     do_op(v, x, -);
2181   }
2182   return v;
2183 }
2184
2185 static sen_obj *
2186 nf_mul(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2187 {
2188   register cell *v, *x;
2189   if (CAR(args)->type == sen_ql_bulk && CADR(args)->type == sen_ql_int) {
2190     int i, n = (int)IVALUE(CADR(args));
2191     sen_rbuf buf;
2192     sen_rbuf_init(&buf, 0);
2193     POP(x, args);
2194     for (i = 0; i < n; i++) {
2195       sen_obj_inspect(ctx, x, &buf, 0);
2196     }
2197     SEN_RBUF2OBJ(ctx, &buf, v);
2198   } else {
2199     v = mk_number(ctx, 1);
2200     while (PAIRP(args)) {
2201       POP(x, args);
2202       do_op(v, x, *);
2203     }
2204   }
2205   return v;
2206 }
2207
2208 static sen_obj *
2209 nf_div(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2210 {
2211   register cell *v;
2212   register cell *x;
2213   if (PAIRP(args) && CDR(args) != NIL) {
2214     v = mk_number(ctx, 0);
2215     POP(x, args);
2216     do_op(v, x, +);
2217   } else {
2218     v = mk_number(ctx, 1);
2219   }
2220   while (PAIRP(args)) {
2221     POP(x, args);
2222     if (x->type == sen_ql_int && IVALUE(x) == 0 && v->type == sen_ql_int) {
2223       SETFLOAT(v, (double)IVALUE(v));
2224     }
2225     do_op(v, x, /);
2226   }
2227   return v;
2228 }
2229 static sen_obj *
2230 nf_rem(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2231 {
2232   register int64_t v;
2233   register cell *x;
2234   x = args;
2235   if (sen_obj2int(ctx, CAR(x))) {
2236     QLERR("can't convert into integer");
2237   }
2238   v = IVALUE(CAR(x));
2239   while (CDR(x) != NIL) {
2240     x = CDR(x);
2241     if (sen_obj2int(ctx, CAR(x))) {
2242       QLERR("can't convert into integer");
2243     }
2244     if (IVALUE(CAR(x)) != 0)
2245       v %= IVALUE(CAR(x));
2246     else {
2247       QLERR("Divided by zero");
2248     }
2249   }
2250   return mk_number(ctx, v);
2251 }
2252 static sen_obj *
2253 nf_car(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2254 {
2255   if (PAIRP(CAR(args))) {
2256     return CAAR(args);
2257   } else {
2258     QLERR("Unable to car for non-cons cell");
2259   }
2260 }
2261 static sen_obj *
2262 nf_cdr(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2263 {
2264   if (PAIRP(CAR(args))) {
2265     return CDAR(args);
2266   } else {
2267     QLERR("Unable to cdr for non-cons cell");
2268   }
2269 }
2270 static sen_obj *
2271 nf_cons(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2272 {
2273   CDR(args) = CADR(args);
2274   return args;
2275 }
2276 static sen_obj *
2277 nf_not(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2278 {
2279   s_retbool(isfalse(CAR(args)));
2280 }
2281 static sen_obj *
2282 nf_bool(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2283 {
2284   s_retbool(CAR(args) == F || CAR(args) == T);
2285 }
2286 static sen_obj *
2287 nf_null(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2288 {
2289   s_retbool(CAR(args) == NIL);
2290 }
2291 static sen_obj *
2292 nf_zerop(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2293 {
2294   register cell *x = CAR(args);
2295   switch (x->type) {
2296   case sen_ql_int :
2297     s_retbool(IVALUE(x) == 0);
2298     break;
2299   case sen_ql_float :
2300     s_retbool(!(islessgreater(FVALUE(x), 0.0)));
2301     break;
2302   default :
2303     QLERR("can't convert into numeric value");
2304   }
2305 }
2306 static sen_obj *
2307 nf_posp(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2308 {
2309   register cell *x = CAR(args);
2310   switch (x->type) {
2311   case sen_ql_int :
2312     s_retbool(IVALUE(x) > 0);
2313     break;
2314   case sen_ql_float :
2315     s_retbool(!(isgreater(FVALUE(x), 0.0)));
2316     break;
2317   default :
2318     QLERR("can't convert into numeric value");
2319   }
2320 }
2321 static sen_obj *
2322 nf_negp(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2323 {
2324   register cell *x = CAR(args);
2325   switch (x->type) {
2326   case sen_ql_int :
2327     s_retbool(IVALUE(x) < 0);
2328     break;
2329   case sen_ql_float :
2330     s_retbool(!(isless(FVALUE(x), 0.0)));
2331     break;
2332   default :
2333     QLERR("can't convert into numeric value");
2334   }
2335 }
2336 static sen_obj *
2337 nf_neq(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2338 {
2339   int r = 1;
2340   register cell *x, *y;
2341   POP(x, args);
2342   if (!PAIRP(args)) { QLERR("Few arguments"); }
2343   do {
2344     POP(y, args);
2345     switch (x->type) {
2346     case sen_ql_int :
2347       switch (y->type) {
2348       case sen_ql_int :
2349         r = (IVALUE(x) == IVALUE(y));
2350         break;
2351       case sen_ql_float :
2352         r = (IVALUE(x) <= FVALUE(y) && IVALUE(x) >= FVALUE(y));
2353         break;
2354       default :
2355         if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }
2356         r = (IVALUE(x) == IVALUE(y));
2357       }
2358       break;
2359     case sen_ql_float :
2360       switch (y->type) {
2361       case sen_ql_int :
2362         r = (FVALUE(x) <= IVALUE(y) && FVALUE(x) >= IVALUE(y));
2363         break;
2364       case sen_ql_float :
2365         r = (FVALUE(x) <= FVALUE(y) && FVALUE(x) >= FVALUE(y));
2366         break;
2367       default :
2368         if (sen_obj2int(ctx, y)) { QLERR("can't convert into numeric value"); }
2369         r = (FVALUE(x) <= IVALUE(y) && FVALUE(x) >= IVALUE(y));
2370       }
2371       break;
2372     case sen_ql_bulk :
2373       if (y->type == sen_ql_bulk) {
2374         int r_;
2375         uint32_t la = x->u.b.size, lb = y->u.b.size;
2376         if (la > lb) {
2377           if (!(r_ = memcmp(x->u.b.value, y->u.b.value, lb))) {
2378             r_ = 1;
2379           }
2380         } else {
2381           if (!(r_ = memcmp(x->u.b.value, y->u.b.value, la))) {
2382             r_ = la == lb ? 0 : -1;
2383           }
2384         }
2385         r = (r_ == 0);
2386       } else {
2387         QLERR("can't compare");
2388       }
2389       break;
2390     case sen_ql_time :
2391       if (y->type == sen_ql_time) {
2392         if (x->u.tv.tv_sec != y->u.tv.tv_sec) {
2393           r = (x->u.tv.tv_sec == y->u.tv.tv_sec);
2394         } else {
2395           r = (x->u.tv.tv_usec == y->u.tv.tv_usec);
2396         }
2397       } else {
2398         QLERR("can't compare");
2399       }
2400     default :
2401       r = (memcmp(&x->u.tv, &y->u.tv, sizeof(sen_timeval)) == 0);
2402     }
2403     x = y;
2404   } while (PAIRP(args) && r);
2405   return r ? T : F;
2406 }
2407 static sen_obj *
2408 nf_less(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2409 {
2410   int r = 1;
2411   register cell *x, *y;
2412   POP(x, args);
2413   if (!PAIRP(args)) { QLERR("Few arguments"); }
2414   do {
2415     POP(y, args);
2416     do_compare(x, y, r, <);
2417     x = y;
2418   } while (PAIRP(args) && r);
2419   return r ? T : F;
2420 }
2421 static sen_obj *
2422 nf_gre(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2423 {
2424   int r = 1;
2425   register cell *x, *y;
2426   POP(x, args);
2427   if (!PAIRP(args)) { QLERR("Few arguments"); }
2428   do {
2429     POP(y, args);
2430     do_compare(x, y, r, >);
2431     x = y;
2432   } while (PAIRP(args) && r);
2433   return r ? T : F;
2434 }
2435 static sen_obj *
2436 nf_leq(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2437 {
2438   int r = 1;
2439   register cell *x, *y;
2440   POP(x, args);
2441   if (!PAIRP(args)) { QLERR("Few arguments"); }
2442   do {
2443     POP(y, args);
2444     do_compare(x, y, r, <=);
2445     x = y;
2446   } while (PAIRP(args) && r);
2447   return r ? T : F;
2448 }
2449 static sen_obj *
2450 nf_geq(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2451 {
2452   int r = 1;
2453   register cell *x, *y;
2454   POP(x, args);
2455   if (!PAIRP(args)) { QLERR("Few arguments"); }
2456   do {
2457     POP(y, args);
2458     do_compare(x, y, r, >=);
2459     x = y;
2460   } while (PAIRP(args) && r);
2461   return r ? T : F;
2462 }
2463 static sen_obj *
2464 nf_symbol(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2465 {
2466   s_retbool(SYMBOLP(CAR(args)));
2467 }
2468 static sen_obj *
2469 nf_number(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2470 {
2471   s_retbool(NUMBERP(CAR(args)));
2472 }
2473 static sen_obj *
2474 nf_string(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2475 {
2476   s_retbool(BULKP(CAR(args)));
2477 }
2478 static sen_obj *
2479 nf_proc(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2480 {
2481   /*--
2482    * continuation should be procedure by the example
2483    * (call-with-current-continuation procedure?) ==> #t
2484    * in R^3 report sec. 6.9
2485    */
2486   s_retbool(PROCP(CAR(args)) || CLOSUREP(CAR(args)) || CONTINUATIONP(CAR(args)));
2487 }
2488 static sen_obj *
2489 nf_pair(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2490 {
2491   s_retbool(PAIRP(CAR(args)));
2492 }
2493 static sen_obj *
2494 nf_eq(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2495 {
2496   s_retbool(CAR(args) == CADR(args));
2497 }
2498 static sen_obj *
2499 nf_eqv(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2500 {
2501   s_retbool(eqv(CAR(args), CADR(args)));
2502 }
2503 static sen_obj *
2504 nf_write(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2505 {
2506   args = CAR(args);
2507   sen_obj_inspect(ctx, args, &ctx->outbuf, SEN_OBJ_INSPECT_ESC);
2508   return T;
2509 }
2510 static sen_obj *
2511 nf_display(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2512 {
2513   args = CAR(args);
2514   sen_obj_inspect(ctx, args, &ctx->outbuf, 0);
2515   return T;
2516 }
2517 static sen_obj *
2518 nf_newline(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2519 {
2520   SEN_RBUF_PUTC(&ctx->outbuf, '\n');
2521   return T;
2522 }
2523 static sen_obj *
2524 nf_reverse(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2525 {
2526   return reverse(ctx, CAR(args));
2527 }
2528 static sen_obj *
2529 nf_append(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2530 {
2531   return append(ctx, CAR(args), CADR(args));
2532 }
2533 static sen_obj *
2534 nf_gc(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2535 {
2536   sen_ctx_mgc(ctx);
2537   sen_index_expire();
2538   // gc(NIL, NIL);
2539   return T;
2540 }
2541 static sen_obj *
2542 nf_gcverb(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2543 {
2544   int  was = ctx->gc_verbose;
2545   ctx->gc_verbose = (CAR(args) != F);
2546   s_retbool(was);
2547 }
2548 static sen_obj *
2549 nf_nativep(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2550 {
2551   s_retbool(NATIVE_FUNCP(CAR(args)));
2552 }
2553 static sen_obj *
2554 nf_length(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2555 {
2556   register long v;
2557   register cell *x;
2558   for (x = CAR(args), v = 0; PAIRP(x); x = CDR(x)) { ++v; }
2559   return mk_number(ctx, v);
2560 }
2561 static sen_obj *
2562 nf_assq(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2563 {
2564   register cell *x, *y;
2565   x = CAR(args);
2566   for (y = CADR(args); PAIRP(y); y = CDR(y)) {
2567     if (!PAIRP(CAR(y))) {
2568       QLERR("Unable to handle non pair element");
2569     }
2570     if (x == CAAR(y))
2571       break;
2572   }
2573   if (PAIRP(y)) {
2574     return CAR(y);
2575   } else {
2576     return F;
2577   }
2578 }
2579 static sen_obj *
2580 nf_get_closure(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2581 {
2582   args = CAR(args);
2583   if (args == NIL) {
2584     return F;
2585   } else if (CLOSUREP(args)) {
2586     return CONS(LAMBDA, CLOSURE_CODE(ctx->value));
2587   } else if (MACROP(args)) {
2588     return CONS(LAMBDA, CLOSURE_CODE(ctx->value));
2589   } else {
2590     return F;
2591   }
2592 }
2593 static sen_obj *
2594 nf_closurep(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2595 {
2596   /*
2597    * Note, macro object is also a closure.
2598    * Therefore, (closure? <#MACRO>) ==> #t
2599    */
2600   if (CAR(args) == NIL) {
2601       return F;
2602   }
2603   s_retbool(CLOSUREP(CAR(args)));
2604 }
2605 static sen_obj *
2606 nf_macrop(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2607 {
2608   if (CAR(args) == NIL) {
2609       return F;
2610   }
2611   s_retbool(MACROP(CAR(args)));
2612 }
2613 static sen_obj *
2614 nf_voidp(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2615 {
2616   s_retbool(CAR(args)->type == sen_ql_void);
2617 }
2618 static sen_obj *
2619 nf_list(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2620 {
2621   if (PAIRP(args)) {
2622     return args;
2623   } else {
2624     QLERR("Unable to handle non-cons argument");
2625   }
2626 }
2627 static sen_obj *
2628 nf_batchmode(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2629 {
2630   if (CAR(args) == F) {
2631     ctx->batchmode = 0;
2632     return F;
2633   } else {
2634     ctx->batchmode = 1;
2635     return T;
2636   }
2637 }
2638 static sen_obj *
2639 nf_loglevel(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2640 {
2641   static sen_logger_info info;
2642   cell *x = CAR(args);
2643   if (sen_obj2int(ctx, x)) { QLERR("can't convert into integer"); }
2644   info.max_level = IVALUE(x);
2645   info.flags = SEN_LOG_TIME|SEN_LOG_MESSAGE;
2646   info.func = NULL;
2647   info.func_arg = NULL;
2648   return (sen_logger_info_set(&info)) ? F : T;
2649 }
2650 static sen_obj *
2651 nf_now(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2652 {
2653   cell *x;
2654   sen_timeval tv;
2655   if (sen_timeval_now(&tv)) { QLERR("sysdate failed"); }
2656   SEN_OBJ_NEW(ctx, x);
2657   SETTIME(x, &tv);
2658   return x;
2659 }
2660 static sen_obj *
2661 nf_timestr(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2662 {
2663   sen_timeval tv;
2664   char buf[SEN_TIMEVAL_STR_SIZE];
2665   cell *x = CAR(args);
2666   switch (x->type) {
2667   case sen_ql_bulk :
2668     if (sen_obj2int(ctx, x)) { QLERR("can't convert into integer"); }
2669     /* fallthru */
2670   case sen_ql_int :
2671     tv.tv_sec = IVALUE(x);
2672     tv.tv_usec = 0;
2673     break;
2674   case sen_ql_float :
2675     tv.tv_sec = (int32_t) FVALUE(x);
2676     tv.tv_usec = (int32_t) ((FVALUE(x) - tv.tv_sec) * 1000000);
2677     break;
2678   case sen_ql_time :
2679     memcpy(&tv, &x->u.tv, sizeof(sen_timeval));
2680     break;
2681   default :
2682     QLERR("can't convert into time");
2683   }
2684   if (sen_timeval2str(&tv, buf)) { QLERR("timeval2str failed"); }
2685   return sen_ql_mk_string(ctx, buf, strlen(buf));
2686 }
2687 static sen_obj *
2688 nf_tonumber(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2689 {
2690   sen_obj *x, *v;
2691   if (!PAIRP(args)) { QLERR("list required"); }
2692   x = CAR(args);
2693   switch (x->type) {
2694   case sen_ql_bulk :
2695     if ((v = str2num(ctx, STRVALUE(x), x->u.b.size)) == NIL) { v = mk_number(ctx, 0); }
2696     break;
2697   case sen_ql_int :
2698   case sen_ql_float :
2699     v = x;
2700     break;
2701   case sen_ql_time :
2702     {
2703       double dv= x->u.tv.tv_sec;
2704       dv += x->u.tv.tv_usec / 1000000.0;
2705       SEN_OBJ_NEW(ctx, v);
2706       SETFLOAT(v, dv);
2707     }
2708     break;
2709   default :
2710     QLERR("can't convert into number");
2711   }
2712   return v;
2713 }
2714 static sen_obj *
2715 nf_totime(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2716 {
2717   sen_timeval tv;
2718   sen_obj *x, *v;
2719   if (!PAIRP(args)) { QLERR("list required"); }
2720   x = CAR(args);
2721   switch (x->type) {
2722   case sen_ql_bulk :
2723     {
2724       /*
2725       if (PAIRP(CDR(args)) && BULKP(CADR(args))) { fmt = STRVALUE(CADR(args)); }
2726       */
2727       if (sen_str2timeval(STRVALUE(x), x->u.b.size, &tv)) {
2728         QLERR("cast error");
2729       }
2730       SEN_OBJ_NEW(ctx, v);
2731       SETTIME(v, &tv);
2732     }
2733     break;
2734   case sen_ql_int :
2735     tv.tv_sec = (int32_t) IVALUE(x);
2736     tv.tv_usec = 0;
2737     SEN_OBJ_NEW(ctx, v);
2738     SETTIME(v, &tv);
2739     break;
2740   case sen_ql_float :
2741     tv.tv_sec = (int32_t) FVALUE(x);
2742     tv.tv_usec = (int32_t) ((FVALUE(x) - tv.tv_sec) * 1000000);
2743     SEN_OBJ_NEW(ctx, v);
2744     SETTIME(v, &tv);
2745     break;
2746   case sen_ql_time :
2747     v = x;
2748     break;
2749   default :
2750     QLERR("can't convert into number");
2751   }
2752   return v;
2753 }
2754 static sen_obj *
2755 nf_substrb(sen_ctx *ctx, sen_obj *args, sen_ql_co *co)
2756 {
2757   sen_obj *str, *s, *e;
2758   int64_t is, ie;
2759   if (!PAIRP(args)) { QLERR("list required"); }
2760   POP(str, args);
2761   if (!BULKP(str)) { QLERR("string required"); }
2762   POP(s, args);
2763   if (!INTP(s)) { QLERR("integer required"); }
2764   POP(e, args);
2765   if (!INTP(e)) { QLERR("integer required"); }
2766   is = IVALUE(s);
2767   ie = IVALUE(e) + 1;
2768   if (ie <= 0) {
2769     ie = str->u.b.size + ie;
2770     if (ie < 0) { ie = 0; }
2771   } else if (ie > str->u.b.size) {
2772     ie = str->u.b.size;
2773   }
2774   if (is < 0) {
2775     is = str->u.b.size + is + 1;
2776     if (is < 0) { is = 0; }
2777   } else if (is > str->u.b.size) {
2778     is = str->u.b.size;
2779   }
2780   if (is < ie) {
2781     return sen_ql_mk_string(ctx, STRVALUE(str) + is, ie - is);
2782   } else {
2783     sen_obj *o;
2784     SEN_OBJ_NEW(ctx, o);
2785     o->flags = 0;
2786     o->type = sen_ql_bulk;
2787     o->u.b.size = 0;
2788     o->u.b.value = NULL;
2789     return o;
2790   }
2791 }
2792
2793 /* ========== Initialization of internal keywords ========== */
2794
2795 inline static void
2796 mk_syntax(sen_ctx *ctx, uint8_t op, char *name)
2797 {
2798   cell *x;
2799   if ((x = INTERN(name)) != F) {
2800     x->type = sen_ql_syntax;
2801     SYNTAXNUM(x) = op;
2802   }
2803 }
2804
2805 inline static void
2806 mk_proc(sen_ctx *ctx, uint8_t op, char *name)
2807 {
2808   cell *x;
2809   if ((x = INTERN(name)) != F) {
2810     x->type = sen_ql_proc;
2811     IVALUE(x) = (int64_t) op;
2812   }
2813 }
2814
2815 void
2816 sen_ql_init_const(void)
2817 {
2818   static sen_obj _NIL, _T, _F;
2819   /* init NIL */
2820   NIL = &_NIL;
2821   NIL->type = sen_ql_void;
2822   CAR(NIL) = CDR(NIL) = NIL;
2823   /* init T */
2824   T = &_T;
2825   T->type = sen_ql_void;
2826   CAR(T) = CDR(T) = T;
2827   /* init F */
2828   F = &_F;
2829   F->type = sen_ql_void;
2830   CAR(F) = CDR(F) = F;
2831 }
2832
2833 inline static void
2834 init_vars_global(sen_ctx *ctx)
2835 {
2836   cell *x;
2837   /* init global_env */
2838   ctx->global_env = CONS(NIL, NIL);
2839   /* init else */
2840   if ((x = INTERN("else")) != F) {
2841     CAR(ctx->global_env) = CONS(CONS(x, T), CAR(ctx->global_env));
2842   }
2843 }
2844
2845 inline static void
2846 init_syntax(sen_ctx *ctx)
2847 {
2848   /* init syntax */
2849   mk_syntax(ctx, OP_LAMBDA, "lambda");
2850   mk_syntax(ctx, OP_QUOTE, "quote");
2851   mk_syntax(ctx, OP_DEF0, "define");
2852   mk_syntax(ctx, OP_IF0, "if");
2853   mk_syntax(ctx, OP_BEGIN, "begin");
2854   mk_syntax(ctx, OP_SET0, "set!");
2855   mk_syntax(ctx, OP_LET0, "let");
2856   mk_syntax(ctx, OP_LET0AST, "let*");
2857   mk_syntax(ctx, OP_LET0REC, "letrec");
2858   mk_syntax(ctx, OP_COND0, "cond");
2859   mk_syntax(ctx, OP_DELAY, "delay");
2860   mk_syntax(ctx, OP_AND0, "and");
2861   mk_syntax(ctx, OP_OR0, "or");
2862   mk_syntax(ctx, OP_C0STREAM, "cons-stream");
2863   mk_syntax(ctx, OP_0MACRO, "define-macro");
2864   mk_syntax(ctx, OP_CASE0, "case");
2865   mk_syntax(ctx, OP_QQUOTE0, "quasiquote");
2866 }
2867
2868 inline static void
2869 init_procs(sen_ctx *ctx)
2870 {
2871   /* init procedure */
2872   mk_proc(ctx, OP_PEVAL, "eval");
2873   mk_proc(ctx, OP_PAPPLY, "apply");
2874   mk_proc(ctx, OP_CONTINUATION, "call-with-current-continuation");
2875   mk_proc(ctx, OP_FORCE, "force");
2876   mk_proc(ctx, OP_SETCAR, "set-car!");
2877   mk_proc(ctx, OP_SETCDR, "set-cdr!");
2878   mk_proc(ctx, OP_READ, "read");
2879   mk_proc(ctx, OP_LOAD, "load");
2880   mk_proc(ctx, OP_ERR1, "error");
2881   mk_proc(ctx, OP_PUT, "put");
2882   mk_proc(ctx, OP_GET, "get");
2883   mk_proc(ctx, OP_QUIT, "quit");
2884   mk_proc(ctx, OP_SDOWN, "shutdown");
2885   sen_ql_def_native_func(ctx, "+", nf_add);
2886   sen_ql_def_native_func(ctx, "-", nf_sub);
2887   sen_ql_def_native_func(ctx, "*", nf_mul);
2888   sen_ql_def_native_func(ctx, "/", nf_div);
2889   sen_ql_def_native_func(ctx, "remainder", nf_rem);
2890   sen_ql_def_native_func(ctx, "car", nf_car);
2891   sen_ql_def_native_func(ctx, "cdr", nf_cdr);
2892   sen_ql_def_native_func(ctx, "cons", nf_cons);
2893   sen_ql_def_native_func(ctx, "not", nf_not);
2894   sen_ql_def_native_func(ctx, "boolean?", nf_bool);
2895   sen_ql_def_native_func(ctx, "symbol?", nf_symbol);
2896   sen_ql_def_native_func(ctx, "number?", nf_number);
2897   sen_ql_def_native_func(ctx, "string?", nf_string);
2898   sen_ql_def_native_func(ctx, "procedure?", nf_proc);
2899   sen_ql_def_native_func(ctx, "pair?", nf_pair);
2900   sen_ql_def_native_func(ctx, "eqv?", nf_eqv);
2901   sen_ql_def_native_func(ctx, "eq?", nf_eq);
2902   sen_ql_def_native_func(ctx, "null?", nf_null);
2903   sen_ql_def_native_func(ctx, "zero?", nf_zerop);
2904   sen_ql_def_native_func(ctx, "positive?", nf_posp);
2905   sen_ql_def_native_func(ctx, "negative?", nf_negp);
2906   sen_ql_def_native_func(ctx, "=", nf_neq);
2907   sen_ql_def_native_func(ctx, "<", nf_less);
2908   sen_ql_def_native_func(ctx, ">", nf_gre);
2909   sen_ql_def_native_func(ctx, "<=", nf_leq);
2910   sen_ql_def_native_func(ctx, ">=", nf_geq);
2911   sen_ql_def_native_func(ctx, "write", nf_write);
2912   sen_ql_def_native_func(ctx, "display", nf_display);
2913   sen_ql_def_native_func(ctx, "newline", nf_newline);
2914   sen_ql_def_native_func(ctx, "reverse", nf_reverse);
2915   sen_ql_def_native_func(ctx, "append", nf_append);
2916   sen_ql_def_native_func(ctx, "gc", nf_gc);
2917   sen_ql_def_native_func(ctx, "gc-verbose", nf_gcverb);
2918   sen_ql_def_native_func(ctx, "native?", nf_nativep);
2919   sen_ql_def_native_func(ctx, "length", nf_length);  /* a.k */
2920   sen_ql_def_native_func(ctx, "assq", nf_assq);  /* a.k */
2921   sen_ql_def_native_func(ctx, "get-closure-code", nf_get_closure);  /* a.k */
2922   sen_ql_def_native_func(ctx, "closure?", nf_closurep);  /* a.k */
2923   sen_ql_def_native_func(ctx, "macro?", nf_macrop);  /* a.k */
2924   sen_ql_def_native_func(ctx, "void?", nf_voidp);
2925   sen_ql_def_native_func(ctx, "list", nf_list);
2926   sen_ql_def_native_func(ctx, "batchmode", nf_batchmode);
2927   sen_ql_def_native_func(ctx, "loglevel", nf_loglevel);
2928   sen_ql_def_native_func(ctx, "now", nf_now);
2929   sen_ql_def_native_func(ctx, "timestr", nf_timestr);
2930   sen_ql_def_native_func(ctx, "x->time", nf_totime);
2931   sen_ql_def_native_func(ctx, "x->number", nf_tonumber);
2932   sen_ql_def_native_func(ctx, "substrb", nf_substrb);
2933 }
2934
2935 /* initialize several globals */
2936 void
2937 sen_ql_init_globals(sen_ctx *ctx)
2938 {
2939   init_vars_global(ctx);
2940   init_syntax(ctx);
2941   init_procs(ctx);
2942   ctx->output = sen_ctx_concat_func;
2943   /* intialization of global pointers to special symbols */
2944 }