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