gerbv  2.10.1-dev~93f1b5
scheme.c
Go to the documentation of this file.
1 /* T I N Y S C H E M E 1 . 3 5
2  * Dimitrios Souflis (dsouflis@acm.org)
3  * Based on MiniScheme (original credits follow)
4  * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
5  * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
6  * (MINISCM) This version has been modified by R.C. Secrist.
7  * (MINISCM)
8  * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
9  * (MINISCM)
10  * (MINISCM) This is a revised and modified version by Akira KIDA.
11  * (MINISCM) current version is 0.85k4 (15 May 1994)
12  *
13  */
14 
20 #include <assert.h>
21 
22 #ifdef HAVE_CONFIG_H
23 #include <config.h>
24 #endif
25 
26 #define _SCHEME_SOURCE
27 #include "scheme-private.h"
28 #ifndef WIN32
29 #include <unistd.h>
30 #endif
31 #if USE_DL
32 #include "dynload.h"
33 #endif
34 #if USE_MATH
35 #include <math.h>
36 #endif
37 #include <limits.h>
38 #include <float.h>
39 #include <ctype.h>
40 #ifdef HAVE_UNISTD_H
41 #include <unistd.h> /* access() on Linux */
42 #endif
43 #include <stddef.h>
44 
45 #if USE_STRCASECMP
46 #include <strings.h>
47 #define stricmp strcasecmp
48 #endif
49 
50 /* Used for documentation purposes, to signal functions in 'interface' */
51 #define INTERFACE
52 
53 #define TOK_EOF (-1)
54 #define TOK_LPAREN 0
55 #define TOK_RPAREN 1
56 #define TOK_DOT 2
57 #define TOK_ATOM 3
58 #define TOK_QUOTE 4
59 #define TOK_COMMENT 5
60 #define TOK_DQUOTE 6
61 #define TOK_BQUOTE 7
62 #define TOK_COMMA 8
63 #define TOK_ATMARK 9
64 #define TOK_SHARP 10
65 #define TOK_SHARP_CONST 11
66 #define TOK_VEC 12
67 
68 #define BACKQUOTE '`'
69 
70 /*
71  * Basic memory allocation units
72  */
73 
74 #define banner "TinyScheme 1.35"
75 
76 #ifdef HAVE_STRING_H
77 #include <string.h>
78 #endif
79 #include <stdlib.h>
80 #ifndef macintosh
81 #ifdef HAVE_MALLOC_H
82 #include <malloc.h>
83 #endif
84 #else
85 static int
86 stricmp(const char* s1, const char* s2) {
87  unsigned char c1, c2;
88  do {
89  c1 = tolower(*s1);
90  c2 = tolower(*s2);
91  if (c1 < c2)
92  return -1;
93  else if (c1 > c2)
94  return 1;
95  s1++, s2++;
96  } while (c1 != 0);
97  return 0;
98 }
99 #endif /* macintosh */
100 
101 #ifndef HAVE_STRLWR
102 static const char*
103 strlwr(char* s) {
104  const char* p = s;
105  while (*s) {
106  *s = tolower((int)*s);
107  s++;
108  }
109  return p;
110 }
111 #endif
112 
113 #ifndef prompt
114 #define prompt "> "
115 #endif
116 
117 #ifndef InitFile
118 #define InitFile "init.scm"
119 #endif
120 
121 #ifndef FIRST_CELLSEGS
122 #define FIRST_CELLSEGS 3
123 #endif
124 
125 enum scheme_types {
126  T_STRING = 1,
127  T_NUMBER = 2,
128  T_SYMBOL = 3,
129  T_PROC = 4,
130  T_PAIR = 5,
131  T_CLOSURE = 6,
132  T_CONTINUATION = 7,
133  T_FOREIGN = 8,
134  T_CHARACTER = 9,
135  T_PORT = 10,
136  T_VECTOR = 11,
137  T_MACRO = 12,
138  T_PROMISE = 13,
139  T_ENVIRONMENT = 14,
140  T_LAST_SYSTEM_TYPE = 14
141 };
142 
143 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
144 #define ADJ 32
145 #define TYPE_BITS 5
146 #define T_MASKTYPE 31 /* 0000000000011111 */
147 #define T_SYNTAX 4096 /* 0001000000000000 */
148 #define T_IMMUTABLE 8192 /* 0010000000000000 */
149 #define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
150 #define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
151 #define MARK 32768 /* 1000000000000000 */
152 #define UNMARK 32767 /* 0111111111111111 */
153 
154 static num num_add(num a, num b);
155 static num num_mul(num a, num b);
156 static num num_div(num a, num b);
157 static num num_intdiv(num a, num b);
158 static num num_sub(num a, num b);
159 static num num_rem(num a, num b);
160 static num num_mod(num a, num b);
161 static int num_eq(num a, num b);
162 static int num_gt(num a, num b);
163 static int num_ge(num a, num b);
164 static int num_lt(num a, num b);
165 static int num_le(num a, num b);
166 
167 #if USE_MATH
168 static double round_per_R5RS(double x);
169 #endif
170 static int is_zero_double(double x);
171 
172 static num num_zero;
173 static num num_one;
174 
175 /* macros for cell operations */
176 #define typeflag(p) ((p)->_flag)
177 #define type(p) (typeflag(p) & T_MASKTYPE)
178 
179 INTERFACE INLINE int
180 is_string(pointer p) {
181  return (type(p) == T_STRING);
182 }
183 
184 #define strvalue(p) ((p)->_object._string._svalue)
185 #define strlength(p) ((p)->_object._string._length)
186 
187 INTERFACE INLINE int
188 is_vector(pointer p) {
189  return (type(p) == T_VECTOR);
190 }
191 
192 INTERFACE static void fill_vector(pointer vec, pointer obj);
193 INTERFACE static pointer vector_elem(pointer vec, int ielem);
194 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
195 
196 INTERFACE INLINE int
197 is_number(pointer p) {
198  return (type(p) == T_NUMBER);
199 }
200 
201 INTERFACE INLINE int
202 is_integer(pointer p) {
203  return ((p)->_object._number.is_fixnum);
204 }
205 
206 INTERFACE INLINE int
207 is_real(pointer p) {
208  return (!(p)->_object._number.is_fixnum);
209 }
210 
211 INTERFACE INLINE int
212 is_character(pointer p) {
213  return (type(p) == T_CHARACTER);
214 }
215 
216 INTERFACE INLINE char*
217 string_value(pointer p) {
218  return strvalue(p);
219 }
220 
221 INLINE num
222 nvalue(pointer p) {
223  return ((p)->_object._number);
224 }
225 
226 INTERFACE long
227 ivalue(pointer p) {
228  return (is_integer(p) ? (p)->_object._number.value.ivalue : (long)(p)->_object._number.value.rvalue);
229 }
230 
231 INTERFACE double
232 rvalue(pointer p) {
233  return (!is_integer(p) ? (p)->_object._number.value.rvalue : (double)(p)->_object._number.value.ivalue);
234 }
235 
236 #define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
237 #define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
238 #define set_integer(p) (p)->_object._number.is_fixnum = 1;
239 #define set_real(p) (p)->_object._number.is_fixnum = 0;
240 
241 INTERFACE long
242 charvalue(pointer p) {
243  return ivalue_unchecked(p);
244 }
245 
246 INTERFACE INLINE int
247 is_port(pointer p) {
248  return (type(p) == T_PORT);
249 }
250 
251 #define is_inport(p) (type(p) == T_PORT && p->_object._port->kind & port_input)
252 #define is_outport(p) (type(p) == T_PORT && p->_object._port->kind & port_output)
253 
254 INTERFACE INLINE int
255 is_pair(pointer p) {
256  return (type(p) == T_PAIR);
257 }
258 
259 #define car(p) ((p)->_object._cons._car)
260 #define cdr(p) ((p)->_object._cons._cdr)
261 
262 INTERFACE pointer
263 pair_car(pointer p) {
264  return car(p);
265 }
266 
267 INTERFACE pointer
268 pair_cdr(pointer p) {
269  return cdr(p);
270 }
271 
272 INTERFACE pointer
273 set_car(pointer p, pointer q) {
274  return car(p) = q;
275 }
276 
277 INTERFACE pointer
278 set_cdr(pointer p, pointer q) {
279  return cdr(p) = q;
280 }
281 
282 INTERFACE INLINE int
283 is_symbol(pointer p) {
284  return (type(p) == T_SYMBOL);
285 }
286 
287 INTERFACE INLINE char*
288 symname(pointer p) {
289  return strvalue(car(p));
290 }
291 #if USE_PLIST
292 SCHEME_EXPORT INLINE int
293 hasprop(pointer p) {
294  return (typeflag(p) & T_SYMBOL);
295 }
296 
297 #define symprop(p) cdr(p)
298 #endif
299 
300 INTERFACE INLINE int
301 is_syntax(pointer p) {
302  return (typeflag(p) & T_SYNTAX);
303 }
304 
305 INTERFACE INLINE int
306 is_proc(pointer p) {
307  return (type(p) == T_PROC);
308 }
309 
310 INTERFACE INLINE int
311 is_foreign(pointer p) {
312  return (type(p) == T_FOREIGN);
313 }
314 
315 INTERFACE INLINE char*
316 syntaxname(pointer p) {
317  return strvalue(car(p));
318 }
319 
320 #define procnum(p) ivalue(p)
321 static const char* procname(pointer x);
322 
323 INTERFACE INLINE int
324 is_closure(pointer p) {
325  return (type(p) == T_CLOSURE);
326 }
327 
328 INTERFACE INLINE int
329 is_macro(pointer p) {
330  return (type(p) == T_MACRO);
331 }
332 
333 INTERFACE INLINE pointer
334 closure_code(pointer p) {
335  return car(p);
336 }
337 
338 INTERFACE INLINE pointer
339 closure_env(pointer p) {
340  return cdr(p);
341 }
342 
343 INTERFACE INLINE int
344 is_continuation(pointer p) {
345  return (type(p) == T_CONTINUATION);
346 }
347 
348 #define cont_dump(p) cdr(p)
349 
350 /* To do: promise should be forced ONCE only */
351 INTERFACE INLINE int
352 is_promise(pointer p) {
353  return (type(p) == T_PROMISE);
354 }
355 
356 INTERFACE INLINE int
357 is_environment(pointer p) {
358  return (type(p) == T_ENVIRONMENT);
359 }
360 
361 #define setenvironment(p) typeflag(p) = T_ENVIRONMENT
362 
363 #define is_atom(p) (typeflag(p) & T_ATOM)
364 #define setatom(p) typeflag(p) |= T_ATOM
365 #define clratom(p) typeflag(p) &= CLRATOM
366 
367 #define is_mark(p) (typeflag(p) & MARK)
368 #define setmark(p) typeflag(p) |= MARK
369 #define clrmark(p) typeflag(p) &= UNMARK
370 
371 INTERFACE INLINE int
372 is_immutable(pointer p) {
373  return (typeflag(p) & T_IMMUTABLE);
374 }
375 
376 /*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
377 INTERFACE INLINE void
378 setimmutable(pointer p) {
379  typeflag(p) |= T_IMMUTABLE;
380 }
381 
382 #define caar(p) car(car(p))
383 #define cadr(p) car(cdr(p))
384 #define cdar(p) cdr(car(p))
385 #define cddr(p) cdr(cdr(p))
386 #define cadar(p) car(cdr(car(p)))
387 #define caddr(p) car(cdr(cdr(p)))
388 #define cadaar(p) car(cdr(car(car(p))))
389 #define cadddr(p) car(cdr(cdr(cdr(p))))
390 #define cddddr(p) cdr(cdr(cdr(cdr(p))))
391 
392 #if USE_CHAR_CLASSIFIERS
393 static INLINE int
394 Cisalpha(int c) {
395  return isascii(c) && isalpha(c);
396 }
397 
398 static INLINE int
399 Cisdigit(int c) {
400  return isascii(c) && isdigit(c);
401 }
402 
403 static INLINE int
404 Cisspace(int c) {
405  return isascii(c) && isspace(c);
406 }
407 
408 static INLINE int
409 Cisupper(int c) {
410  return isascii(c) && isupper(c);
411 }
412 
413 static INLINE int
414 Cislower(int c) {
415  return isascii(c) && islower(c);
416 }
417 #endif
418 
419 #if USE_ASCII_NAMES
420 static const char* charnames[32] = { "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", "bs", "ht", "lf",
421  "vt", "ff", "cr", "so", "si", "dle", "dc1", "dc2", "dc3", "dc4", "nak",
422  "syn", "etb", "can", "em", "sub", "esc", "fs", "gs", "rs", "us" };
423 
424 static int
425 is_ascii_name(const char* name, int* pc) {
426  int i;
427  for (i = 0; i < 32; i++) {
428  if (stricmp(name, charnames[i]) == 0) {
429  *pc = i;
430  return 1;
431  }
432  }
433  if (stricmp(name, "del") == 0) {
434  *pc = 127;
435  return 1;
436  }
437  return 0;
438 }
439 
440 #endif
441 
442 static int file_push(scheme* sc, const char* fname);
443 static void file_pop(scheme* sc);
444 static int file_interactive(scheme* sc);
445 static INLINE int is_one_of(char* s, int c);
446 static int alloc_cellseg(scheme* sc, int n);
447 static long binary_decode(const char* s);
448 static INLINE pointer get_cell(scheme* sc, pointer a, pointer b);
449 static pointer _get_cell(scheme* sc, pointer a, pointer b);
450 static pointer get_consecutive_cells(scheme* sc, int n);
451 static pointer find_consecutive_cells(scheme* sc, int n);
452 static void finalize_cell(scheme* sc, pointer a);
453 static int count_consecutive_cells(pointer x, int needed);
454 static pointer find_slot_in_env(scheme* sc, pointer env, pointer sym, int all);
455 static pointer mk_number(scheme* sc, num n);
456 static pointer mk_empty_string(scheme* sc, int len, char fill);
457 static char* store_string(scheme* sc, int len, const char* str, char fill);
458 static pointer mk_vector(scheme* sc, int len);
459 static pointer mk_atom(scheme* sc, char* q);
460 static pointer mk_sharp_const(scheme* sc, char* name);
461 static pointer mk_port(scheme* sc, port* p);
462 static pointer port_from_filename(scheme* sc, const char* fn, int prop);
463 static pointer port_from_file(scheme* sc, FILE*, int prop);
464 static pointer port_from_string(scheme* sc, char* start, char* past_the_end, int prop);
465 static port* port_rep_from_filename(scheme* sc, const char* fn, int prop);
466 static port* port_rep_from_file(scheme* sc, FILE*, int prop);
467 static port* port_rep_from_string(scheme* sc, char* start, char* past_the_end, int prop);
468 static void port_close(scheme* sc, pointer p, int flag);
469 static void mark(pointer a);
470 static void gc(scheme* sc, pointer a, pointer b);
471 static int basic_inchar(port* pt);
472 static int inchar(scheme* sc);
473 static void backchar(scheme* sc, int c);
474 static char* readstr_upto(scheme* sc, char* delim);
475 static pointer readstrexp(scheme* sc);
476 static INLINE void skipspace(scheme* sc);
477 static int token(scheme* sc);
478 static void printslashstring(scheme* sc, char* s, int len);
479 static void atom2str(scheme* sc, pointer l, int f, char** pp, int* plen);
480 static void printatom(scheme* sc, pointer l, int f);
481 static pointer mk_proc(scheme* sc, enum scheme_opcodes op);
482 static pointer mk_closure(scheme* sc, pointer c, pointer e);
483 static pointer mk_continuation(scheme* sc, pointer d);
484 static pointer reverse(scheme* sc, pointer a);
485 static pointer reverse_in_place(scheme* sc, pointer term, pointer list);
486 static pointer append(scheme* sc, pointer a, pointer b);
487 static int list_length(scheme* sc, pointer a);
488 static int eqv(pointer a, pointer b);
489 static void dump_stack_mark(scheme*);
490 static pointer opexe_0(scheme* sc, enum scheme_opcodes op);
491 static pointer opexe_1(scheme* sc, enum scheme_opcodes op);
492 static pointer opexe_2(scheme* sc, enum scheme_opcodes op);
493 static pointer opexe_3(scheme* sc, enum scheme_opcodes op);
494 static pointer opexe_4(scheme* sc, enum scheme_opcodes op);
495 static pointer opexe_5(scheme* sc, enum scheme_opcodes op);
496 static pointer opexe_6(scheme* sc, enum scheme_opcodes op);
497 static void Eval_Cycle(scheme* sc, enum scheme_opcodes op);
498 static void assign_syntax(scheme* sc, char* name);
499 static int syntaxnum(pointer p);
500 static void assign_proc(scheme* sc, enum scheme_opcodes, char* name);
501 
502 #define num_ivalue(n) (n.is_fixnum ? (n).value.ivalue : (long)(n).value.rvalue)
503 #define num_rvalue(n) (!n.is_fixnum ? (n).value.rvalue : (double)(n).value.ivalue)
504 
505 static num
506 num_add(num a, num b) {
507  num ret;
508  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
509  if (ret.is_fixnum) {
510  ret.value.ivalue = a.value.ivalue + b.value.ivalue;
511  } else {
512  ret.value.rvalue = num_rvalue(a) + num_rvalue(b);
513  }
514  return ret;
515 }
516 
517 static num
518 num_mul(num a, num b) {
519  num ret;
520  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
521  if (ret.is_fixnum) {
522  ret.value.ivalue = a.value.ivalue * b.value.ivalue;
523  } else {
524  ret.value.rvalue = num_rvalue(a) * num_rvalue(b);
525  }
526  return ret;
527 }
528 
529 static num
530 num_div(num a, num b) {
531  num ret;
532  ret.is_fixnum = a.is_fixnum && b.is_fixnum && a.value.ivalue % b.value.ivalue == 0;
533  if (ret.is_fixnum) {
534  ret.value.ivalue = a.value.ivalue / b.value.ivalue;
535  } else {
536  ret.value.rvalue = num_rvalue(a) / num_rvalue(b);
537  }
538  return ret;
539 }
540 
541 static num
542 num_intdiv(num a, num b) {
543  num ret;
544  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
545  if (ret.is_fixnum) {
546  ret.value.ivalue = a.value.ivalue / b.value.ivalue;
547  } else {
548  ret.value.rvalue = num_rvalue(a) / num_rvalue(b);
549  }
550  return ret;
551 }
552 
553 static num
554 num_sub(num a, num b) {
555  num ret;
556  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
557  if (ret.is_fixnum) {
558  ret.value.ivalue = a.value.ivalue - b.value.ivalue;
559  } else {
560  ret.value.rvalue = num_rvalue(a) - num_rvalue(b);
561  }
562  return ret;
563 }
564 
565 static num
566 num_rem(num a, num b) {
567  num ret;
568  long e1, e2, res;
569  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
570  e1 = num_ivalue(a);
571  e2 = num_ivalue(b);
572  res = e1 % e2;
573  /* modulo should have same sign as second operand */
574  if (res > 0) {
575  if (e1 < 0) {
576  res -= labs(e2);
577  }
578  } else if (res < 0) {
579  if (e1 > 0) {
580  res += labs(e2);
581  }
582  }
583  ret.value.ivalue = res;
584  return ret;
585 }
586 
587 static num
588 num_mod(num a, num b) {
589  num ret;
590  long e1, e2, res;
591  ret.is_fixnum = a.is_fixnum && b.is_fixnum;
592  e1 = num_ivalue(a);
593  e2 = num_ivalue(b);
594  res = e1 % e2;
595  if (res * e2 < 0) { /* modulo should have same sign as second operand */
596  e2 = labs(e2);
597  if (res > 0) {
598  res -= e2;
599  } else {
600  res += e2;
601  }
602  }
603  ret.value.ivalue = res;
604  return ret;
605 }
606 
607 static int
608 num_eq(num a, num b) {
609  int ret;
610  int is_fixnum = a.is_fixnum && b.is_fixnum;
611  if (is_fixnum) {
612  ret = a.value.ivalue == b.value.ivalue;
613  } else {
614  ret = num_rvalue(a) == num_rvalue(b);
615  }
616  return ret;
617 }
618 
619 static int
620 num_gt(num a, num b) {
621  int ret;
622  int is_fixnum = a.is_fixnum && b.is_fixnum;
623  if (is_fixnum) {
624  ret = a.value.ivalue > b.value.ivalue;
625  } else {
626  ret = num_rvalue(a) > num_rvalue(b);
627  }
628  return ret;
629 }
630 
631 static int
632 num_ge(num a, num b) {
633  return !num_lt(a, b);
634 }
635 
636 static int
637 num_lt(num a, num b) {
638  int ret;
639  int is_fixnum = a.is_fixnum && b.is_fixnum;
640  if (is_fixnum) {
641  ret = a.value.ivalue < b.value.ivalue;
642  } else {
643  ret = num_rvalue(a) < num_rvalue(b);
644  }
645  return ret;
646 }
647 
648 static int
649 num_le(num a, num b) {
650  return !num_gt(a, b);
651 }
652 
653 #if USE_MATH
654 /* Round to nearest. Round to even if midway */
655 static double
656 round_per_R5RS(double x) {
657  double fl = floor(x);
658  double ce = ceil(x);
659  double dfl = x - fl;
660  double dce = ce - x;
661  if (dfl > dce) {
662  return ce;
663  } else if (dfl < dce) {
664  return fl;
665  } else {
666  if (fmod(fl, 2.0) == 0.0) { /* I imagine this holds */
667  return fl;
668  } else {
669  return ce;
670  }
671  }
672 }
673 #endif
674 
675 static int
676 is_zero_double(double x) {
677  return x < DBL_MIN && x > -DBL_MIN;
678 }
679 
680 static long
681 binary_decode(const char* s) {
682  long x = 0;
683 
684  while (*s != 0 && (*s == '1' || *s == '0')) {
685  x <<= 1;
686  x += *s - '0';
687  s++;
688  }
689 
690  return x;
691 }
692 
693 /* allocate new cell segment */
694 static int
695 alloc_cellseg(scheme* sc, int n) {
696  pointer newp;
697  pointer last;
698  pointer p;
699  char* cp;
700  long i;
701  int k;
702  size_t adj = ADJ;
703 
704  if (adj < sizeof(struct cell)) {
705  adj = sizeof(struct cell);
706  }
707 
708  for (k = 0; k < n; k++) {
709  if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
710  return k;
711  cp = (char*)sc->malloc(CELL_SEGSIZE * sizeof(struct cell) + adj);
712  if (cp == 0)
713  return k;
714  i = ++sc->last_cell_seg;
715  sc->alloc_seg[i] = cp;
716  /* adjust in TYPE_BITS-bit boundary */
717  /* Check that the casting below is safe. */
718  static_assert(sizeof(size_t) == sizeof(cp), "Can't cast pointer to size_t.");
719  if ((size_t)cp % adj != 0) {
720  cp = (char*)(adj * ((size_t)cp / adj + 1));
721  }
722  /* insert new segment in address order */
723  newp = (pointer)cp;
724  sc->cell_seg[i] = newp;
725  while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
726  p = sc->cell_seg[i];
727  sc->cell_seg[i] = sc->cell_seg[i - 1];
728  sc->cell_seg[--i] = p;
729  }
730  sc->fcells += CELL_SEGSIZE;
731  last = newp + CELL_SEGSIZE - 1;
732  for (p = newp; p <= last; p++) {
733  typeflag(p) = 0;
734  cdr(p) = p + 1;
735  car(p) = sc->NIL;
736  }
737  /* insert new cells in address order on free list */
738  if (sc->free_cell == sc->NIL || p < sc->free_cell) {
739  cdr(last) = sc->free_cell;
740  sc->free_cell = newp;
741  } else {
742  p = sc->free_cell;
743  while (cdr(p) != sc->NIL && newp > cdr(p))
744  p = cdr(p);
745  cdr(last) = cdr(p);
746  cdr(p) = newp;
747  }
748  }
749  return n;
750 }
751 
752 static INLINE pointer
753 get_cell(scheme* sc, pointer a, pointer b) {
754  if (sc->free_cell != sc->NIL) {
755  pointer x = sc->free_cell;
756  sc->free_cell = cdr(x);
757  --sc->fcells;
758  return (x);
759  }
760  return _get_cell(sc, a, b);
761 }
762 
763 /* get new cell. parameter a, b is marked by gc. */
764 static pointer
765 _get_cell(scheme* sc, pointer a, pointer b) {
766  pointer x;
767 
768  if (sc->no_memory) {
769  return sc->sink;
770  }
771 
772  if (sc->free_cell == sc->NIL) {
773  gc(sc, a, b);
774  if (sc->fcells < sc->last_cell_seg * 8 || sc->free_cell == sc->NIL) {
775  /* if only a few recovered, get more to avoid fruitless gc's */
776  if (!alloc_cellseg(sc, 1) && sc->free_cell == sc->NIL) {
777  sc->no_memory = 1;
778  return sc->sink;
779  }
780  }
781  }
782  x = sc->free_cell;
783  sc->free_cell = cdr(x);
784  --sc->fcells;
785  return (x);
786 }
787 
788 static pointer
789 get_consecutive_cells(scheme* sc, int n) {
790  pointer x;
791 
792  if (sc->no_memory) {
793  return sc->sink;
794  }
795 
796  /* Are there any cells available? */
797  x = find_consecutive_cells(sc, n);
798  if (x == sc->NIL) {
799  /* If not, try gc'ing some */
800  gc(sc, sc->NIL, sc->NIL);
801  x = find_consecutive_cells(sc, n);
802  if (x == sc->NIL) {
803  /* If there still aren't, try getting more heap */
804  if (!alloc_cellseg(sc, 1)) {
805  sc->no_memory = 1;
806  return sc->sink;
807  }
808  }
809  x = find_consecutive_cells(sc, n);
810  if (x == sc->NIL) {
811  /* If all fail, report failure */
812  sc->no_memory = 1;
813  return sc->sink;
814  }
815  }
816  return (x);
817 }
818 
819 static int
820 count_consecutive_cells(pointer x, int needed) {
821  int n = 1;
822  while (cdr(x) == x + 1) {
823  x = cdr(x);
824  n++;
825  if (n > needed)
826  return n;
827  }
828  return n;
829 }
830 
831 static pointer
832 find_consecutive_cells(scheme* sc, int n) {
833  pointer* pp;
834  int cnt;
835 
836  pp = &sc->free_cell;
837  while (*pp != sc->NIL) {
838  cnt = count_consecutive_cells(*pp, n);
839  if (cnt >= n) {
840  pointer x = *pp;
841  *pp = cdr(*pp + n - 1);
842  sc->fcells -= n;
843  return x;
844  }
845  pp = &cdr(*pp + cnt - 1);
846  }
847  return sc->NIL;
848 }
849 
850 /* get new cons cell */
851 pointer
852 _cons(scheme* sc, pointer a, pointer b, int immutable) {
853  pointer x = get_cell(sc, a, b);
854 
855  typeflag(x) = T_PAIR;
856  if (immutable) {
857  setimmutable(x);
858  }
859  car(x) = a;
860  cdr(x) = b;
861  return (x);
862 }
863 
864 /* ========== oblist implementation ========== */
865 
866 #ifndef USE_OBJECT_LIST
867 
868 static int hash_fn(const char* key, int table_size);
869 
870 static pointer
871 oblist_initial_value(scheme* sc) {
872  return mk_vector(sc, 461); /* probably should be bigger */
873 }
874 
875 /* returns the new symbol */
876 static pointer
877 oblist_add_by_name(scheme* sc, const char* name) {
878  pointer x;
879  int location;
880 
881  x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
882  typeflag(x) = T_SYMBOL;
883  setimmutable(car(x));
884 
885  location = hash_fn(name, ivalue_unchecked(sc->oblist));
886  set_vector_elem(sc->oblist, location, immutable_cons(sc, x, vector_elem(sc->oblist, location)));
887  return x;
888 }
889 
890 static INLINE pointer
891 oblist_find_by_name(scheme* sc, const char* name) {
892  int location;
893  pointer x;
894  char* s;
895 
896  location = hash_fn(name, ivalue_unchecked(sc->oblist));
897  for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
898  s = symname(car(x));
899  /* case-insensitive, per R5RS section 2. */
900  if (stricmp(name, s) == 0) {
901  return car(x);
902  }
903  }
904  return sc->NIL;
905 }
906 
907 static pointer
908 oblist_all_symbols(scheme* sc) {
909  int i;
910  pointer x;
911  pointer ob_list = sc->NIL;
912 
913  for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
914  for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
915  ob_list = cons(sc, x, ob_list);
916  }
917  }
918  return ob_list;
919 }
920 
921 #else
922 
923 static pointer
924 oblist_initial_value(scheme* sc) {
925  return sc->NIL;
926 }
927 
928 static INLINE pointer
929 oblist_find_by_name(scheme* sc, const char* name) {
930  pointer x;
931  char* s;
932 
933  for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
934  s = symname(car(x));
935  /* case-insensitive, per R5RS section 2. */
936  if (stricmp(name, s) == 0) {
937  return car(x);
938  }
939  }
940  return sc->NIL;
941 }
942 
943 /* returns the new symbol */
944 static pointer
945 oblist_add_by_name(scheme* sc, const char* name) {
946  pointer x;
947 
948  x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
949  typeflag(x) = T_SYMBOL;
950  setimmutable(car(x));
951  sc->oblist = immutable_cons(sc, x, sc->oblist);
952  return x;
953 }
954 
955 static pointer
956 oblist_all_symbols(scheme* sc) {
957  return sc->oblist;
958 }
959 
960 #endif
961 
962 static pointer
963 mk_port(scheme* sc, port* p) {
964  pointer x = get_cell(sc, sc->NIL, sc->NIL);
965 
966  typeflag(x) = T_PORT | T_ATOM;
967  x->_object._port = p;
968  return (x);
969 }
970 
971 pointer
972 mk_foreign_func(scheme* sc, foreign_func f) {
973  pointer x = get_cell(sc, sc->NIL, sc->NIL);
974 
975  typeflag(x) = (T_FOREIGN | T_ATOM);
976  x->_object._ff = f;
977  return (x);
978 }
979 
980 INTERFACE pointer
981 mk_character(scheme* sc, int c) {
982  pointer x = get_cell(sc, sc->NIL, sc->NIL);
983 
984  typeflag(x) = (T_CHARACTER | T_ATOM);
985  ivalue_unchecked(x) = c;
986  set_integer(x);
987  return (x);
988 }
989 
990 /* get number atom (integer) */
991 INTERFACE pointer
992 mk_integer(scheme* sc, long num) {
993  pointer x = get_cell(sc, sc->NIL, sc->NIL);
994 
995  typeflag(x) = (T_NUMBER | T_ATOM);
996  ivalue_unchecked(x) = num;
997  set_integer(x);
998  return (x);
999 }
1000 
1001 INTERFACE pointer
1002 mk_real(scheme* sc, double n) {
1003  pointer x = get_cell(sc, sc->NIL, sc->NIL);
1004 
1005  typeflag(x) = (T_NUMBER | T_ATOM);
1006  rvalue_unchecked(x) = n;
1007  set_real(x);
1008  return (x);
1009 }
1010 
1011 static pointer
1012 mk_number(scheme* sc, num n) {
1013  if (n.is_fixnum) {
1014  return mk_integer(sc, n.value.ivalue);
1015  } else {
1016  return mk_real(sc, n.value.rvalue);
1017  }
1018 }
1019 
1020 /* allocate name to string area */
1021 static char*
1022 store_string(scheme* sc, int len_str, const char* str, char fill) {
1023  char* q;
1024 
1025  q = (char*)sc->malloc(len_str + 1);
1026  if (q == 0) {
1027  sc->no_memory = 1;
1028  return sc->strbuff;
1029  }
1030  if (str != 0) {
1031  strcpy(q, str);
1032  } else {
1033  memset(q, fill, len_str);
1034  q[len_str] = 0;
1035  }
1036  return (q);
1037 }
1038 
1039 /* get new string */
1040 INTERFACE pointer
1041 mk_string(scheme* sc, const char* str) {
1042  return mk_counted_string(sc, str, strlen(str));
1043 }
1044 
1045 INTERFACE pointer
1046 mk_counted_string(scheme* sc, const char* str, int len) {
1047  pointer x = get_cell(sc, sc->NIL, sc->NIL);
1048 
1049  strvalue(x) = store_string(sc, len, str, 0);
1050  typeflag(x) = (T_STRING | T_ATOM);
1051  strlength(x) = len;
1052  return (x);
1053 }
1054 
1055 static pointer
1056 mk_empty_string(scheme* sc, int len, char fill) {
1057  pointer x = get_cell(sc, sc->NIL, sc->NIL);
1058 
1059  strvalue(x) = store_string(sc, len, 0, fill);
1060  typeflag(x) = (T_STRING | T_ATOM);
1061  strlength(x) = len;
1062  return (x);
1063 }
1064 
1065 INTERFACE static pointer
1066 mk_vector(scheme* sc, int len) {
1067  pointer x = get_consecutive_cells(sc, len / 2 + len % 2 + 1);
1068  typeflag(x) = (T_VECTOR | T_ATOM);
1069  ivalue_unchecked(x) = len;
1070  set_integer(x);
1071  fill_vector(x, sc->NIL);
1072  return x;
1073 }
1074 
1075 INTERFACE static void
1076 fill_vector(pointer vec, pointer obj) {
1077  int i;
1078  int num = ivalue(vec) / 2 + ivalue(vec) % 2;
1079  for (i = 0; i < num; i++) {
1080  typeflag(vec + 1 + i) = T_PAIR;
1081  setimmutable(vec + 1 + i);
1082  car(vec + 1 + i) = obj;
1083  cdr(vec + 1 + i) = obj;
1084  }
1085 }
1086 
1087 INTERFACE static pointer
1088 vector_elem(pointer vec, int ielem) {
1089  int n = ielem / 2;
1090  if (ielem % 2 == 0) {
1091  return car(vec + 1 + n);
1092  } else {
1093  return cdr(vec + 1 + n);
1094  }
1095 }
1096 
1097 INTERFACE static pointer
1098 set_vector_elem(pointer vec, int ielem, pointer a) {
1099  int n = ielem / 2;
1100  if (ielem % 2 == 0) {
1101  return car(vec + 1 + n) = a;
1102  } else {
1103  return cdr(vec + 1 + n) = a;
1104  }
1105 }
1106 
1107 /* get new symbol */
1108 INTERFACE pointer
1109 mk_symbol(scheme* sc, const char* name) {
1110  pointer x;
1111 
1112  /* first check oblist */
1113  x = oblist_find_by_name(sc, name);
1114  if (x != sc->NIL) {
1115  return (x);
1116  } else {
1117  x = oblist_add_by_name(sc, name);
1118  return (x);
1119  }
1120 }
1121 
1122 INTERFACE pointer
1123 gensym(scheme* sc) {
1124  pointer x;
1125  char name[40];
1126 
1127  for (; sc->gensym_cnt < LONG_MAX; sc->gensym_cnt++) {
1128  sprintf(name, "gensym-%ld", sc->gensym_cnt);
1129 
1130  /* first check oblist */
1131  x = oblist_find_by_name(sc, name);
1132 
1133  if (x != sc->NIL) {
1134  continue;
1135  } else {
1136  x = oblist_add_by_name(sc, name);
1137  return (x);
1138  }
1139  }
1140 
1141  return sc->NIL;
1142 }
1143 
1144 /* make symbol or number atom from string */
1145 static pointer
1146 mk_atom(scheme* sc, char* q) {
1147  char c, *p;
1148  int has_dec_point = 0;
1149  int has_fp_exp = 0;
1150 
1151 #if USE_COLON_HOOK
1152  if ((p = strstr(q, "::")) != 0) {
1153  *p = 0;
1154  return cons(
1155  sc, sc->COLON_HOOK,
1156  cons(
1157  sc, cons(sc, sc->QUOTE, cons(sc, mk_atom(sc, p + 2), sc->NIL)),
1158  cons(sc, mk_symbol(sc, strlwr(q)), sc->NIL)
1159  )
1160  );
1161  }
1162 #endif
1163 
1164  p = q;
1165  c = *p++;
1166  if ((c == '+') || (c == '-')) {
1167  c = *p++;
1168  if (c == '.') {
1169  has_dec_point = 1;
1170  c = *p++;
1171  }
1172  if (!isdigit((int)c)) {
1173  return (mk_symbol(sc, strlwr(q)));
1174  }
1175  } else if (c == '.') {
1176  has_dec_point = 1;
1177  c = *p++;
1178  if (!isdigit((int)c)) {
1179  return (mk_symbol(sc, strlwr(q)));
1180  }
1181  } else if (!isdigit((int)c)) {
1182  return (mk_symbol(sc, strlwr(q)));
1183  }
1184 
1185  for (; (c = *p) != 0; ++p) {
1186  if (!isdigit((int)c)) {
1187  if (c == '.') {
1188  if (!has_dec_point) {
1189  has_dec_point = 1;
1190  continue;
1191  }
1192  } else if ((c == 'e') || (c == 'E')) {
1193  if (!has_fp_exp) {
1194  has_dec_point = 1; /* decimal point illegal
1195  from now on */
1196  p++;
1197  if ((*p == '-') || (*p == '+') || isdigit((int)*p)) {
1198  continue;
1199  }
1200  }
1201  }
1202  return (mk_symbol(sc, strlwr(q)));
1203  }
1204  }
1205  if (has_dec_point) {
1206  return mk_real(sc, atof(q));
1207  }
1208  return (mk_integer(sc, atol(q)));
1209 }
1210 
1211 /* make constant */
1212 static pointer
1213 mk_sharp_const(scheme* sc, char* name) {
1214  long x;
1215  char tmp[256];
1216 
1217  if (!strcmp(name, "t"))
1218  return (sc->T);
1219  else if (!strcmp(name, "f"))
1220  return (sc->F);
1221  else if (*name == 'o') { /* #o (octal) */
1222  sprintf(tmp, "0%s", name + 1);
1223  sscanf(tmp, "%lo", &x);
1224  return (mk_integer(sc, x));
1225  } else if (*name == 'd') { /* #d (decimal) */
1226  sscanf(name + 1, "%ld", &x);
1227  return (mk_integer(sc, x));
1228  } else if (*name == 'x') { /* #x (hex) */
1229  sprintf(tmp, "0x%s", name + 1);
1230  sscanf(tmp, "%lx", &x);
1231  return (mk_integer(sc, x));
1232  } else if (*name == 'b') { /* #b (binary) */
1233  x = binary_decode(name + 1);
1234  return (mk_integer(sc, x));
1235  } else if (*name == '\\') { /* #\w (character) */
1236  int c = 0;
1237  if (stricmp(name + 1, "space") == 0) {
1238  c = ' ';
1239  } else if (stricmp(name + 1, "newline") == 0) {
1240  c = '\n';
1241  } else if (stricmp(name + 1, "return") == 0) {
1242  c = '\r';
1243  } else if (stricmp(name + 1, "tab") == 0) {
1244  c = '\t';
1245  } else if (name[1] == 'x' && name[2] != 0) {
1246  int c1 = 0;
1247  if (sscanf(name + 2, "%x", &c1) == 1 && c1 < 256) {
1248  c = c1;
1249  } else {
1250  return sc->NIL;
1251  }
1252 #if USE_ASCII_NAMES
1253  } else if (is_ascii_name(name + 1, &c)) {
1254  /* nothing */
1255 #endif
1256  } else if (name[2] == 0) {
1257  c = name[1];
1258  } else {
1259  return sc->NIL;
1260  }
1261  return mk_character(sc, c);
1262  } else
1263  return (sc->NIL);
1264 }
1265 
1266 /* ========== garbage collector ========== */
1267 
1268 /*--
1269  * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1270  * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1271  * for marking.
1272  */
1273 static void
1274 mark(pointer a) {
1275  pointer t, q, p;
1276 
1277  t = (pointer)0;
1278  p = a;
1279 E2:
1280  setmark(p);
1281  if (is_vector(p)) {
1282  int i;
1283  int num = ivalue_unchecked(p) / 2 + ivalue_unchecked(p) % 2;
1284  for (i = 0; i < num; i++) {
1285  /* Vector cells will be treated like ordinary cells */
1286  mark(p + 1 + i);
1287  }
1288  }
1289  if (is_atom(p))
1290  goto E6;
1291  /* E4: down car */
1292  q = car(p);
1293  if (q && !is_mark(q)) {
1294  setatom(p); /* a note that we have moved car */
1295  car(p) = t;
1296  t = p;
1297  p = q;
1298  goto E2;
1299  }
1300 E5:
1301  q = cdr(p); /* down cdr */
1302  if (q && !is_mark(q)) {
1303  cdr(p) = t;
1304  t = p;
1305  p = q;
1306  goto E2;
1307  }
1308 E6: /* up. Undo the link switching from steps E4 and E5. */
1309  if (!t)
1310  return;
1311  q = t;
1312  if (is_atom(q)) {
1313  clratom(q);
1314  t = car(q);
1315  car(q) = p;
1316  p = q;
1317  goto E5;
1318  } else {
1319  t = cdr(q);
1320  cdr(q) = p;
1321  p = q;
1322  goto E6;
1323  }
1324 }
1325 
1326 /* garbage collection. parameter a, b is marked. */
1327 static void
1328 gc(scheme* sc, pointer a, pointer b) {
1329  pointer p;
1330  int i;
1331 
1332  if (sc->gc_verbose) {
1333  putstr(sc, "gc...");
1334  }
1335 
1336  /* mark system globals */
1337  mark(sc->oblist);
1338  mark(sc->global_env);
1339 
1340  /* mark current registers */
1341  mark(sc->args);
1342  mark(sc->envir);
1343  mark(sc->code);
1344  dump_stack_mark(sc);
1345  mark(sc->value);
1346  mark(sc->inport);
1347  mark(sc->save_inport);
1348  mark(sc->outport);
1349  mark(sc->loadport);
1350 
1351  /* mark variables a, b */
1352  mark(a);
1353  mark(b);
1354 
1355  /* garbage collect */
1356  clrmark(sc->NIL);
1357  sc->fcells = 0;
1358  sc->free_cell = sc->NIL;
1359  /* free-list is kept sorted by address so as to maintain consecutive
1360  ranges, if possible, for use with vectors. Here we scan the cells
1361  (which are also kept sorted by address) downwards to build the
1362  free-list in sorted order.
1363  */
1364  for (i = sc->last_cell_seg; i >= 0; i--) {
1365  p = sc->cell_seg[i] + CELL_SEGSIZE;
1366  while (--p >= sc->cell_seg[i]) {
1367  if (is_mark(p)) {
1368  clrmark(p);
1369  } else {
1370  /* reclaim cell */
1371  if (typeflag(p) != 0) {
1372  finalize_cell(sc, p);
1373  typeflag(p) = 0;
1374  car(p) = sc->NIL;
1375  }
1376  ++sc->fcells;
1377  cdr(p) = sc->free_cell;
1378  sc->free_cell = p;
1379  }
1380  }
1381  }
1382 
1383  if (sc->gc_verbose) {
1384  char msg[80];
1385  sprintf(msg, "done: %ld cells were recovered.\n", sc->fcells);
1386  putstr(sc, msg);
1387  }
1388 }
1389 
1390 static void
1391 finalize_cell(scheme* sc, pointer a) {
1392  if (is_string(a)) {
1393  sc->free(strvalue(a));
1394  } else if (is_port(a)) {
1395  if (a->_object._port->kind & port_file && a->_object._port->rep.stdio.closeit) {
1396  port_close(sc, a, port_input | port_output);
1397  }
1398  sc->free(a->_object._port);
1399  }
1400 }
1401 
1402 /* ========== Routines for Reading ========== */
1403 
1404 static int
1405 file_push(scheme* sc, const char* fname) {
1406  FILE* fin = fopen(fname, "r");
1407  if (fin != 0) {
1408  sc->file_i++;
1409  sc->load_stack[sc->file_i].kind = port_file | port_input;
1410  sc->load_stack[sc->file_i].rep.stdio.file = fin;
1411  sc->load_stack[sc->file_i].rep.stdio.closeit = 1;
1412  sc->nesting_stack[sc->file_i] = 0;
1413  sc->loadport->_object._port = sc->load_stack + sc->file_i;
1414  }
1415  return fin != 0;
1416 }
1417 
1418 static void
1419 file_pop(scheme* sc) {
1420  sc->nesting = sc->nesting_stack[sc->file_i];
1421  if (sc->file_i != 0) {
1422  port_close(sc, sc->loadport, port_input);
1423  sc->file_i--;
1424  sc->loadport->_object._port = sc->load_stack + sc->file_i;
1425  if (file_interactive(sc)) {
1426  putstr(sc, prompt);
1427  }
1428  }
1429 }
1430 
1431 static int
1432 file_interactive(scheme* sc) {
1433  return sc->file_i == 0 && sc->load_stack[0].rep.stdio.file == stdin && sc->inport->_object._port->kind & port_file;
1434 }
1435 
1436 static port*
1437 port_rep_from_filename(scheme* sc, const char* fn, int prop) {
1438  FILE* f;
1439  char* rw;
1440  port* pt;
1441  if (prop == (port_input | port_output)) {
1442  rw = "a+";
1443  } else if (prop == port_output) {
1444  rw = "w";
1445  } else {
1446  rw = "r";
1447  }
1448  f = fopen(fn, rw);
1449  if (f == 0) {
1450  return 0;
1451  }
1452  pt = port_rep_from_file(sc, f, prop);
1453  pt->rep.stdio.closeit = 1;
1454  return pt;
1455 }
1456 
1457 static pointer
1458 port_from_filename(scheme* sc, const char* fn, int prop) {
1459  port* pt;
1460  pt = port_rep_from_filename(sc, fn, prop);
1461  if (pt == 0) {
1462  return sc->NIL;
1463  }
1464  return mk_port(sc, pt);
1465 }
1466 
1467 static port*
1468 port_rep_from_file(scheme* sc, FILE* f, int prop) {
1469  /*char *rw;*/
1470  port* pt;
1471  pt = (port*)sc->malloc(sizeof(port));
1472  if (pt == 0) {
1473  return 0;
1474  }
1475  /*
1476  if(prop==(port_input|port_output)) {
1477  rw="a+";
1478  } else if(prop==port_output) {
1479  rw="w";
1480  } else {
1481  rw="r";
1482  }
1483  */
1484  pt->kind = port_file | prop;
1485  pt->rep.stdio.file = f;
1486  pt->rep.stdio.closeit = 0;
1487  return pt;
1488 }
1489 
1490 static pointer
1491 port_from_file(scheme* sc, FILE* f, int prop) {
1492  port* pt;
1493  pt = port_rep_from_file(sc, f, prop);
1494  if (pt == 0) {
1495  return sc->NIL;
1496  }
1497  return mk_port(sc, pt);
1498 }
1499 
1500 static port*
1501 port_rep_from_string(scheme* sc, char* start, char* past_the_end, int prop) {
1502  port* pt;
1503  pt = (port*)sc->malloc(sizeof(port));
1504  if (pt == 0) {
1505  return 0;
1506  }
1507  pt->kind = port_string | prop;
1508  pt->rep.string.start = start;
1509  pt->rep.string.curr = start;
1510  pt->rep.string.past_the_end = past_the_end;
1511  return pt;
1512 }
1513 
1514 static pointer
1515 port_from_string(scheme* sc, char* start, char* past_the_end, int prop) {
1516  port* pt;
1517  pt = port_rep_from_string(sc, start, past_the_end, prop);
1518  if (pt == 0) {
1519  return sc->NIL;
1520  }
1521  return mk_port(sc, pt);
1522 }
1523 
1524 static void
1525 port_close(scheme* sc, pointer p, int flag) {
1526  port* pt = p->_object._port;
1527  pt->kind &= ~flag;
1528  if ((pt->kind & (port_input | port_output)) == 0) {
1529  if (pt->kind & port_file) {
1530  fclose(pt->rep.stdio.file);
1531  }
1532  pt->kind = port_free;
1533  }
1534 }
1535 
1536 /* get new character from input file */
1537 static int
1538 inchar(scheme* sc) {
1539  int c;
1540  port* pt;
1541 again:
1542  pt = sc->inport->_object._port;
1543  c = basic_inchar(pt);
1544  if (c == EOF && sc->inport == sc->loadport && sc->file_i != 0) {
1545  file_pop(sc);
1546  if (sc->nesting != 0) {
1547  return EOF;
1548  }
1549  goto again;
1550  }
1551  return c;
1552 }
1553 
1554 static int
1555 basic_inchar(port* pt) {
1556  if (pt->kind & port_file) {
1557  return fgetc(pt->rep.stdio.file);
1558  } else {
1559  if (*pt->rep.string.curr == 0 || pt->rep.string.curr == pt->rep.string.past_the_end) {
1560  return EOF;
1561  } else {
1562  return *pt->rep.string.curr++;
1563  }
1564  }
1565 }
1566 
1567 /* back character to input buffer */
1568 static void
1569 backchar(scheme* sc, int c) {
1570  port* pt;
1571  if (c == EOF)
1572  return;
1573  pt = sc->inport->_object._port;
1574  if (pt->kind & port_file) {
1575  ungetc(c, pt->rep.stdio.file);
1576  } else {
1577  if (pt->rep.string.curr != pt->rep.string.start) {
1578  --pt->rep.string.curr;
1579  }
1580  }
1581 }
1582 
1583 INTERFACE void
1584 putstr(scheme* sc, const char* s) {
1585  port* pt = sc->outport->_object._port;
1586  if (pt->kind & port_file) {
1587  fputs(s, pt->rep.stdio.file);
1588  } else {
1589  for (; *s; s++) {
1590  if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1591  *pt->rep.string.curr++ = *s;
1592  }
1593  }
1594  }
1595 }
1596 
1597 static void
1598 putchars(scheme* sc, const char* s, int len) {
1599  port* pt = sc->outport->_object._port;
1600  if (pt->kind & port_file) {
1601  /* use the return value here to eliminate a compiler warning */
1602  if (fwrite(s, 1, len, pt->rep.stdio.file) == 0)
1603  return;
1604  } else {
1605  for (; len; len--) {
1606  if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1607  *pt->rep.string.curr++ = *s++;
1608  }
1609  }
1610  }
1611 }
1612 
1613 INTERFACE void
1614 putcharacter(scheme* sc, int c) {
1615  port* pt = sc->outport->_object._port;
1616  if (pt->kind & port_file) {
1617  fputc(c, pt->rep.stdio.file);
1618  } else {
1619  if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1620  *pt->rep.string.curr++ = c;
1621  }
1622  }
1623 }
1624 
1625 /* read characters up to delimiter, but cater to character constants */
1626 static char*
1627 readstr_upto(scheme* sc, char* delim) {
1628  char* p = sc->strbuff;
1629 
1630  while (!is_one_of(delim, (*p++ = inchar(sc))))
1631  ;
1632  if (p == sc->strbuff + 2 && p[-2] == '\\') {
1633  *p = 0;
1634  } else {
1635  backchar(sc, p[-1]);
1636  *--p = '\0';
1637  }
1638  return sc->strbuff;
1639 }
1640 
1641 /* read string expression "xxx...xxx" */
1642 static pointer
1643 readstrexp(scheme* sc) {
1644  char* p = sc->strbuff;
1645  int c;
1646  int c1 = 0;
1647 
1648  enum {
1649  st_ok,
1650  st_bsl,
1651  st_x1,
1652  st_x2
1653  } state = st_ok;
1654 
1655  for (;;) {
1656  c = inchar(sc);
1657  if (c == EOF || p - sc->strbuff > sizeof(sc->strbuff) - 1) {
1658  return sc->F;
1659  }
1660  switch (state) {
1661  case st_ok:
1662  switch (c) {
1663  case '\\': state = st_bsl; break;
1664  case '"': *p = 0; return mk_counted_string(sc, sc->strbuff, p - sc->strbuff);
1665  default: *p++ = c; break;
1666  }
1667  break;
1668  case st_bsl:
1669  switch (c) {
1670  case 'x':
1671  case 'X':
1672  state = st_x1;
1673  c1 = 0;
1674  break;
1675  case 'n':
1676  *p++ = '\n';
1677  state = st_ok;
1678  break;
1679  case 't':
1680  *p++ = '\t';
1681  state = st_ok;
1682  break;
1683  case 'r':
1684  *p++ = '\r';
1685  state = st_ok;
1686  break;
1687  case '"':
1688  *p++ = '"';
1689  state = st_ok;
1690  break;
1691  default:
1692  *p++ = c;
1693  state = st_ok;
1694  break;
1695  }
1696  break;
1697  case st_x1:
1698  case st_x2:
1699  c = toupper(c);
1700  if (c >= '0' && c <= 'F') {
1701  if (c <= '9') {
1702  c1 = (c1 << 4) + c - '0';
1703  } else {
1704  c1 = (c1 << 4) + c - 'A' + 10;
1705  }
1706  if (state == st_x1) {
1707  state = st_x2;
1708  } else {
1709  *p++ = c1;
1710  state = st_ok;
1711  }
1712  } else {
1713  return sc->F;
1714  }
1715  break;
1716  }
1717  }
1718 }
1719 
1720 /* check c is in chars */
1721 static INLINE int
1722 is_one_of(char* s, int c) {
1723  if (c == EOF)
1724  return 1;
1725  while (*s)
1726  if (*s++ == c)
1727  return (1);
1728  return (0);
1729 }
1730 
1731 /* skip white characters */
1732 static INLINE void
1733 skipspace(scheme* sc) {
1734  int c;
1735  while (isspace(c = inchar(sc)))
1736  ;
1737  if (c != EOF) {
1738  backchar(sc, c);
1739  }
1740 }
1741 
1742 /* get token */
1743 static int
1744 token(scheme* sc) {
1745  int c;
1746  skipspace(sc);
1747  switch (c = inchar(sc)) {
1748  case EOF: return (TOK_EOF);
1749  case '(': return (TOK_LPAREN);
1750  case ')': return (TOK_RPAREN);
1751  case '.':
1752  c = inchar(sc);
1753  if (is_one_of(" \n\t", c)) {
1754  return (TOK_DOT);
1755  } else {
1756  backchar(sc, c);
1757  backchar(sc, '.');
1758  return TOK_ATOM;
1759  }
1760  case '\'': return (TOK_QUOTE);
1761  case ';': return (TOK_COMMENT);
1762  case '"': return (TOK_DQUOTE);
1763  case BACKQUOTE: return (TOK_BQUOTE);
1764  case ',':
1765  if ((c = inchar(sc)) == '@')
1766  return (TOK_ATMARK);
1767  else {
1768  backchar(sc, c);
1769  return (TOK_COMMA);
1770  }
1771  case '#':
1772  c = inchar(sc);
1773  if (c == '(') {
1774  return (TOK_VEC);
1775  } else if (c == '!') {
1776  return TOK_COMMENT;
1777  } else {
1778  backchar(sc, c);
1779  if (is_one_of(" tfodxb\\", c)) {
1780  return TOK_SHARP_CONST;
1781  } else {
1782  return (TOK_SHARP);
1783  }
1784  }
1785  default: backchar(sc, c); return (TOK_ATOM);
1786  }
1787 }
1788 
1789 /* ========== Routines for Printing ========== */
1790 #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
1791 
1792 static void
1793 printslashstring(scheme* sc, char* p, int len) {
1794  int i;
1795  unsigned char* s = (unsigned char*)p;
1796  putcharacter(sc, '"');
1797  for (i = 0; i < len; i++) {
1798  if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\') {
1799  putcharacter(sc, '\\');
1800  switch (*s) {
1801  case '"': putcharacter(sc, '"'); break;
1802  case '\n': putcharacter(sc, 'n'); break;
1803  case '\t': putcharacter(sc, 't'); break;
1804  case '\r': putcharacter(sc, 'r'); break;
1805  case '\\': putcharacter(sc, '\\'); break;
1806  default:
1807  {
1808  int d = *s / 16;
1809  putcharacter(sc, 'x');
1810  if (d < 10) {
1811  putcharacter(sc, d + '0');
1812  } else {
1813  putcharacter(sc, d - 10 + 'A');
1814  }
1815  d = *s % 16;
1816  if (d < 10) {
1817  putcharacter(sc, d + '0');
1818  } else {
1819  putcharacter(sc, d - 10 + 'A');
1820  }
1821  }
1822  }
1823  } else {
1824  putcharacter(sc, *s);
1825  }
1826  s++;
1827  }
1828  putcharacter(sc, '"');
1829 }
1830 
1831 /* print atoms */
1832 static void
1833 printatom(scheme* sc, pointer l, int f) {
1834  char* p;
1835  int len;
1836  atom2str(sc, l, f, &p, &len);
1837  putchars(sc, p, len);
1838 }
1839 
1840 /* Uses internal buffer unless string pointer is already available */
1841 static void
1842 atom2str(scheme* sc, pointer l, int f, char** pp, int* plen) {
1843  char* p;
1844 
1845  if (l == sc->NIL) {
1846  p = "()";
1847  } else if (l == sc->T) {
1848  p = "#t";
1849  } else if (l == sc->F) {
1850  p = "#f";
1851  } else if (l == sc->EOF_OBJ) {
1852  p = "#<EOF>";
1853  } else if (is_port(l)) {
1854  p = sc->strbuff;
1855  strcpy(p, "#<PORT>");
1856  } else if (is_number(l)) {
1857  p = sc->strbuff;
1858  if (is_integer(l)) {
1859  sprintf(p, "%ld", ivalue_unchecked(l));
1860  } else {
1861  sprintf(p, "%.10g", rvalue_unchecked(l));
1862  }
1863  } else if (is_string(l)) {
1864  if (!f) {
1865  p = strvalue(l);
1866  } else { /* Hack, uses the fact that printing is needed */
1867  *pp = sc->strbuff;
1868  *plen = 0;
1869  printslashstring(sc, strvalue(l), strlength(l));
1870  return;
1871  }
1872  } else if (is_character(l)) {
1873  int c = charvalue(l);
1874  p = sc->strbuff;
1875  if (!f) {
1876  p[0] = c;
1877  p[1] = 0;
1878  } else {
1879  switch (c) {
1880  case ' ': sprintf(p, "#\\space"); break;
1881  case '\n': sprintf(p, "#\\newline"); break;
1882  case '\r': sprintf(p, "#\\return"); break;
1883  case '\t': sprintf(p, "#\\tab"); break;
1884  default:
1885 #if USE_ASCII_NAMES
1886  if (c == 127) {
1887  strcpy(p, "#\\del");
1888  break;
1889  } else if (c < 32) {
1890  strcpy(p, "#\\");
1891  strcat(p, charnames[c]);
1892  break;
1893  }
1894 #else
1895  if (c < 32) {
1896  sprintf(p, "#\\x%x", c);
1897  break;
1898  }
1899 #endif
1900  sprintf(p, "#\\%c", c);
1901  break;
1902  }
1903  }
1904  } else if (is_symbol(l)) {
1905  p = symname(l);
1906  } else if (is_proc(l)) {
1907  p = sc->strbuff;
1908  sprintf(p, "#<%s PROCEDURE %ld>", procname(l), procnum(l));
1909  } else if (is_macro(l)) {
1910  p = "#<MACRO>";
1911  } else if (is_closure(l)) {
1912  p = "#<CLOSURE>";
1913  } else if (is_promise(l)) {
1914  p = "#<PROMISE>";
1915  } else if (is_foreign(l)) {
1916  p = sc->strbuff;
1917  sprintf(p, "#<FOREIGN PROCEDURE %ld>", procnum(l));
1918  } else if (is_continuation(l)) {
1919  p = "#<CONTINUATION>";
1920  } else {
1921  p = "#<ERROR>";
1922  }
1923  *pp = p;
1924  *plen = strlen(p);
1925 }
1926 
1927 /* ========== Routines for Evaluation Cycle ========== */
1928 
1929 /* make closure. c is code. e is environment */
1930 static pointer
1931 mk_closure(scheme* sc, pointer c, pointer e) {
1932  pointer x = get_cell(sc, c, e);
1933 
1934  typeflag(x) = T_CLOSURE;
1935  car(x) = c;
1936  cdr(x) = e;
1937  return (x);
1938 }
1939 
1940 /* make continuation. */
1941 static pointer
1942 mk_continuation(scheme* sc, pointer d) {
1943  pointer x = get_cell(sc, sc->NIL, d);
1944 
1945  typeflag(x) = T_CONTINUATION;
1946  cont_dump(x) = d;
1947  return (x);
1948 }
1949 
1950 static pointer
1951 list_star(scheme* sc, pointer d) {
1952  pointer p, q;
1953  if (cdr(d) == sc->NIL) {
1954  return car(d);
1955  }
1956  p = cons(sc, car(d), cdr(d));
1957  q = p;
1958  while (cdr(cdr(p)) != sc->NIL) {
1959  d = cons(sc, car(p), cdr(p));
1960  if (cdr(cdr(p)) != sc->NIL) {
1961  p = cdr(d);
1962  }
1963  }
1964  cdr(p) = car(cdr(p));
1965  return q;
1966 }
1967 
1968 /* reverse list -- produce new list */
1969 static pointer
1970 reverse(scheme* sc, pointer a) {
1971  /* a must be checked by gc */
1972  pointer p = sc->NIL;
1973 
1974  for (; is_pair(a); a = cdr(a)) {
1975  p = cons(sc, car(a), p);
1976  }
1977  return (p);
1978 }
1979 
1980 /* reverse list --- in-place */
1981 static pointer
1982 reverse_in_place(scheme* sc, pointer term, pointer list) {
1983  pointer p = list, result = term, q;
1984 
1985  while (p != sc->NIL) {
1986  q = cdr(p);
1987  cdr(p) = result;
1988  result = p;
1989  p = q;
1990  }
1991  return (result);
1992 }
1993 
1994 /* append list -- produce new list */
1995 static pointer
1996 append(scheme* sc, pointer a, pointer b) {
1997  pointer p = b, q;
1998 
1999  if (a != sc->NIL) {
2000  a = reverse(sc, a);
2001  while (a != sc->NIL) {
2002  q = cdr(a);
2003  cdr(a) = p;
2004  p = a;
2005  a = q;
2006  }
2007  }
2008  return (p);
2009 }
2010 
2011 /* equivalence of atoms */
2012 static int
2013 eqv(pointer a, pointer b) {
2014  if (is_string(a)) {
2015  if (is_string(b))
2016  return (strvalue(a) == strvalue(b));
2017  else
2018  return (0);
2019  } else if (is_number(a)) {
2020  if (is_number(b))
2021  return num_eq(nvalue(a), nvalue(b));
2022  else
2023  return (0);
2024  } else if (is_character(a)) {
2025  if (is_character(b))
2026  return charvalue(a) == charvalue(b);
2027  else
2028  return (0);
2029  } else if (is_port(a)) {
2030  if (is_port(b))
2031  return a == b;
2032  else
2033  return (0);
2034  } else if (is_proc(a)) {
2035  if (is_proc(b))
2036  return procnum(a) == procnum(b);
2037  else
2038  return (0);
2039  } else {
2040  return (a == b);
2041  }
2042 }
2043 
2044 /* true or false value macro */
2045 /* () is #t in R5RS */
2046 #define is_true(p) ((p) != sc->F)
2047 #define is_false(p) ((p) == sc->F)
2048 
2049 /* ========== Environment implementation ========== */
2050 
2051 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2052 
2053 static int
2054 hash_fn(const char* key, int table_size) {
2055  unsigned int hashed = 0;
2056  const char* c;
2057  int bits_per_int = sizeof(unsigned int) * 8;
2058 
2059  for (c = key; *c; c++) {
2060  /* letters have about 5 bits in them */
2061  hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
2062  hashed ^= *c;
2063  }
2064  return hashed % table_size;
2065 }
2066 #endif
2067 
2068 #ifndef USE_ALIST_ENV
2069 
2070 /*
2071  * In this implementation, each frame of the environment may be
2072  * a hash table: a vector of alists hashed by variable name.
2073  * In practice, we use a vector only for the initial frame;
2074  * subsequent frames are too small and transient for the lookup
2075  * speed to out-weigh the cost of making a new vector.
2076  */
2077 
2078 static void
2079 new_frame_in_env(scheme* sc, pointer old_env) {
2080  pointer new_frame;
2081 
2082  /* The interaction-environment has about 300 variables in it. */
2083  if (old_env == sc->NIL) {
2084  new_frame = mk_vector(sc, 461);
2085  } else {
2086  new_frame = sc->NIL;
2087  }
2088 
2089  sc->envir = immutable_cons(sc, new_frame, old_env);
2090  setenvironment(sc->envir);
2091 }
2092 
2093 static INLINE void
2094 new_slot_spec_in_env(scheme* sc, pointer env, pointer variable, pointer value) {
2095  pointer slot = immutable_cons(sc, variable, value);
2096 
2097  if (is_vector(car(env))) {
2098  int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2099 
2100  set_vector_elem(car(env), location, immutable_cons(sc, slot, vector_elem(car(env), location)));
2101  } else {
2102  car(env) = immutable_cons(sc, slot, car(env));
2103  }
2104 }
2105 
2106 static pointer
2107 find_slot_in_env(scheme* sc, pointer env, pointer hdl, int all) {
2108  pointer x = sc->NIL, y = sc->NIL;
2109  int location = 0;
2110 
2111  for (x = env; x != sc->NIL; x = cdr(x)) {
2112  if (is_vector(car(x))) {
2113  location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2114  y = vector_elem(car(x), location);
2115  } else {
2116  y = car(x);
2117  }
2118  for (; y != sc->NIL; y = cdr(y)) {
2119  if (caar(y) == hdl) {
2120  break;
2121  }
2122  }
2123  if (y != sc->NIL) {
2124  break;
2125  }
2126  if (!all) {
2127  return sc->NIL;
2128  }
2129  }
2130  if (x != sc->NIL) {
2131  return car(y);
2132  }
2133  return sc->NIL;
2134 }
2135 
2136 #else /* USE_ALIST_ENV */
2137 
2138 static INLINE void
2139 new_frame_in_env(scheme* sc, pointer old_env) {
2140  sc->envir = immutable_cons(sc, sc->NIL, old_env);
2141  setenvironment(sc->envir);
2142 }
2143 
2144 static INLINE void
2145 new_slot_spec_in_env(scheme* sc, pointer env, pointer variable, pointer value) {
2146  car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2147 }
2148 
2149 static pointer
2150 find_slot_in_env(scheme* sc, pointer env, pointer hdl, int all) {
2151  pointer x, y;
2152  for (x = env; x != sc->NIL; x = cdr(x)) {
2153  for (y = car(x); y != sc->NIL; y = cdr(y)) {
2154  if (caar(y) == hdl) {
2155  break;
2156  }
2157  }
2158  if (y != sc->NIL) {
2159  break;
2160  }
2161  if (!all) {
2162  return sc->NIL;
2163  }
2164  }
2165  if (x != sc->NIL) {
2166  return car(y);
2167  }
2168  return sc->NIL;
2169 }
2170 
2171 #endif /* USE_ALIST_ENV else */
2172 
2173 static INLINE void
2174 new_slot_in_env(scheme* sc, pointer variable, pointer value) {
2175  new_slot_spec_in_env(sc, sc->envir, variable, value);
2176 }
2177 
2178 static INLINE void
2179 set_slot_in_env(scheme* sc, pointer slot, pointer value) {
2180  cdr(slot) = value;
2181 }
2182 
2183 static INLINE pointer
2184 slot_value_in_env(pointer slot) {
2185  return cdr(slot);
2186 }
2187 
2188 /* ========== Evaluation Cycle ========== */
2189 
2190 static pointer
2191 _Error_1(scheme* sc, const char* s, pointer a) {
2192 #if USE_ERROR_HOOK
2193  pointer x;
2194  pointer hdl = sc->ERROR_HOOK;
2195 
2196  x = find_slot_in_env(sc, sc->envir, hdl, 1);
2197  if (x != sc->NIL) {
2198  if (a != 0) {
2199  sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, (a), sc->NIL)), sc->NIL);
2200  } else {
2201  sc->code = sc->NIL;
2202  }
2203  sc->code = cons(sc, mk_string(sc, (s)), sc->code);
2204  setimmutable(car(sc->code));
2205  sc->code = cons(sc, slot_value_in_env(x), sc->code);
2206  sc->op = (int)OP_EVAL;
2207  return sc->T;
2208  }
2209 #endif
2210 
2211  if (a != 0) {
2212  sc->args = cons(sc, (a), sc->NIL);
2213  } else {
2214  sc->args = sc->NIL;
2215  }
2216  sc->args = cons(sc, mk_string(sc, (s)), sc->args);
2217  setimmutable(car(sc->args));
2218  sc->op = (int)OP_ERR0;
2219  return sc->T;
2220 }
2221 
2222 #define Error_1(sc, s, a) return _Error_1(sc, s, a)
2223 #define Error_0(sc, s) return _Error_1(sc, s, 0)
2224 
2225 /* Too small to turn into function */
2226 #define BEGIN do {
2227 #define END \
2228  } \
2229  while (0)
2230 #define s_goto(sc, a) \
2231  BEGIN \
2232  sc->op = (int)(a); \
2233  return sc->T; \
2234  END
2235 
2236 #define s_return(sc, a) return _s_return(sc, a)
2237 
2238 #ifndef USE_SCHEME_STACK
2239 
2240 /* this structure holds all the interpreter's registers */
2241 struct dump_stack_frame {
2242  enum scheme_opcodes op;
2243  pointer args;
2244  pointer envir;
2245  pointer code;
2246 };
2247 
2248 #define STACK_GROWTH 3
2249 
2250 static void
2251 s_save(scheme* sc, enum scheme_opcodes op, pointer args, pointer code) {
2252  long nframes = (long)sc->dump;
2253  struct dump_stack_frame* next_frame;
2254 
2255  /* enough room for the next frame? */
2256  if (nframes >= sc->dump_size) {
2257  sc->dump_size += STACK_GROWTH;
2258  /* alas there is no sc->realloc */
2259  sc->dump_base = realloc(sc->dump_base, sizeof(struct dump_stack_frame) * sc->dump_size);
2260  }
2261  next_frame = (struct dump_stack_frame*)sc->dump_base + nframes;
2262  next_frame->op = op;
2263  next_frame->args = args;
2264  next_frame->envir = sc->envir;
2265  next_frame->code = code;
2266  sc->dump = (pointer)(nframes + 1L);
2267 }
2268 
2269 static pointer
2270 _s_return(scheme* sc, pointer a) {
2271  long nframes = (long)sc->dump;
2272  struct dump_stack_frame* frame;
2273 
2274  sc->value = (a);
2275  if (nframes <= 0) {
2276  return sc->NIL;
2277  }
2278  nframes--;
2279  frame = (struct dump_stack_frame*)sc->dump_base + nframes;
2280  sc->op = frame->op;
2281  sc->args = frame->args;
2282  sc->envir = frame->envir;
2283  sc->code = frame->code;
2284  sc->dump = (pointer)nframes;
2285  return sc->T;
2286 }
2287 
2288 static INLINE void
2289 dump_stack_reset(scheme* sc) {
2290  /* in this implementation, sc->dump is the number of frames on the stack */
2291  sc->dump = (pointer)0;
2292 }
2293 
2294 static INLINE void
2295 dump_stack_initialize(scheme* sc) {
2296  sc->dump_size = 0;
2297  sc->dump_base = NULL;
2298  dump_stack_reset(sc);
2299 }
2300 
2301 static void
2302 dump_stack_free(scheme* sc) {
2303  free(sc->dump_base);
2304  sc->dump_base = NULL;
2305  sc->dump = (pointer)0;
2306  sc->dump_size = 0;
2307 }
2308 
2309 static INLINE void
2310 dump_stack_mark(scheme* sc) {
2311  long nframes = (long)sc->dump;
2312  int i;
2313  for (i = 0; i < nframes; i++) {
2314  struct dump_stack_frame* frame;
2315  frame = (struct dump_stack_frame*)sc->dump_base + i;
2316  mark(frame->args);
2317  mark(frame->envir);
2318  mark(frame->code);
2319  }
2320 }
2321 
2322 #else
2323 
2324 static INLINE void
2325 dump_stack_reset(scheme* sc) {
2326  sc->dump = sc->NIL;
2327 }
2328 
2329 static INLINE void
2330 dump_stack_initialize(scheme* sc) {
2331  dump_stack_reset(sc);
2332 }
2333 
2334 static void
2335 dump_stack_free(scheme* sc) {
2336  sc->dump = sc->NIL;
2337 }
2338 
2339 static pointer
2340 _s_return(scheme* sc, pointer a) {
2341  sc->value = (a);
2342  if (sc->dump == sc->NIL)
2343  return sc->NIL;
2344  sc->op = ivalue(car(sc->dump));
2345  sc->args = cadr(sc->dump);
2346  sc->envir = caddr(sc->dump);
2347  sc->code = cadddr(sc->dump);
2348  sc->dump = cddddr(sc->dump);
2349  return sc->T;
2350 }
2351 
2352 static void
2353 s_save(scheme* sc, enum scheme_opcodes op, pointer args, pointer code) {
2354  sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2355  sc->dump = cons(sc, (args), sc->dump);
2356  sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2357 }
2358 
2359 static INLINE void
2360 dump_stack_mark(scheme* sc) {
2361  mark(sc->dump);
2362 }
2363 #endif
2364 
2365 #define s_retbool(tf) s_return(sc, (tf) ? sc->T : sc->F)
2366 
2367 static pointer
2368 opexe_0(scheme* sc, enum scheme_opcodes op) {
2369  pointer x, y;
2370 
2371  switch (op) {
2372  case OP_LOAD: /* load */
2373  if (file_interactive(sc)) {
2374  fprintf(sc->outport->_object._port->rep.stdio.file, "Loading %s\n", strvalue(car(sc->args)));
2375  }
2376  if (!file_push(sc, strvalue(car(sc->args)))) {
2377  Error_1(sc, "unable to open", car(sc->args));
2378  }
2379  s_goto(sc, OP_T0LVL);
2380 
2381  case OP_T0LVL: /* top level */
2382  if (file_interactive(sc)) {
2383  putstr(sc, "\n");
2384  }
2385  sc->nesting = 0;
2386  dump_stack_reset(sc);
2387  sc->envir = sc->global_env;
2388  sc->save_inport = sc->inport;
2389  sc->inport = sc->loadport;
2390  s_save(sc, OP_T0LVL, sc->NIL, sc->NIL);
2391  s_save(sc, OP_VALUEPRINT, sc->NIL, sc->NIL);
2392  s_save(sc, OP_T1LVL, sc->NIL, sc->NIL);
2393  if (file_interactive(sc)) {
2394  putstr(sc, prompt);
2395  }
2396  s_goto(sc, OP_READ_INTERNAL);
2397 
2398  case OP_T1LVL: /* top level */
2399  sc->code = sc->value;
2400  sc->inport = sc->save_inport;
2401  s_goto(sc, OP_EVAL);
2402 
2403  case OP_READ_INTERNAL: /* internal read */
2404  sc->tok = token(sc);
2405  if (sc->tok == TOK_EOF) {
2406  if (sc->inport == sc->loadport) {
2407  sc->args = sc->NIL;
2408  s_goto(sc, OP_QUIT);
2409  } else {
2410  s_return(sc, sc->EOF_OBJ);
2411  }
2412  }
2413  s_goto(sc, OP_RDSEXPR);
2414 
2415  case OP_GENSYM: s_return(sc, gensym(sc));
2416 
2417  case OP_VALUEPRINT: /* print evaluation result */
2418  /* OP_VALUEPRINT is always pushed, because when changing from
2419  non-interactive to interactive mode, it needs to be
2420  already on the stack */
2421  if (sc->tracing) {
2422  putstr(sc, "\nGives: ");
2423  }
2424  if (file_interactive(sc)) {
2425  sc->print_flag = 1;
2426  sc->args = sc->value;
2427  s_goto(sc, OP_P0LIST);
2428  } else {
2429  s_return(sc, sc->value);
2430  }
2431 
2432  case OP_EVAL: /* main part of evaluation */
2433 #if USE_TRACING
2434  if (sc->tracing) {
2435  /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2436  s_save(sc, OP_REAL_EVAL, sc->args, sc->code);
2437  sc->args = sc->code;
2438  putstr(sc, "\nEval: ");
2439  s_goto(sc, OP_P0LIST);
2440  }
2441  /* fall through */
2442  case OP_REAL_EVAL:
2443 #endif
2444  if (is_symbol(sc->code)) { /* symbol */
2445  x = find_slot_in_env(sc, sc->envir, sc->code, 1);
2446  if (x != sc->NIL) {
2447  s_return(sc, slot_value_in_env(x));
2448  } else {
2449  Error_1(sc, "eval: unbound variable:", sc->code);
2450  }
2451  } else if (is_pair(sc->code)) {
2452  if (is_syntax(x = car(sc->code))) { /* SYNTAX */
2453  sc->code = cdr(sc->code);
2454  s_goto(sc, syntaxnum(x));
2455  } else { /* first, eval top element and eval arguments */
2456  s_save(sc, OP_E0ARGS, sc->NIL, sc->code);
2457  /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2458  sc->code = car(sc->code);
2459  s_goto(sc, OP_EVAL);
2460  }
2461  } else {
2462  s_return(sc, sc->code);
2463  }
2464 
2465  case OP_E0ARGS: /* eval arguments */
2466  if (is_macro(sc->value)) { /* macro expansion */
2467  s_save(sc, OP_DOMACRO, sc->NIL, sc->NIL);
2468  sc->args = cons(sc, sc->code, sc->NIL);
2469  sc->code = sc->value;
2470  s_goto(sc, OP_APPLY);
2471  } else {
2472  sc->code = cdr(sc->code);
2473  s_goto(sc, OP_E1ARGS);
2474  }
2475 
2476  case OP_E1ARGS: /* eval arguments */
2477  sc->args = cons(sc, sc->value, sc->args);
2478  if (is_pair(sc->code)) { /* continue */
2479  s_save(sc, OP_E1ARGS, sc->args, cdr(sc->code));
2480  sc->code = car(sc->code);
2481  sc->args = sc->NIL;
2482  s_goto(sc, OP_EVAL);
2483  } else { /* end */
2484  sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2485  sc->code = car(sc->args);
2486  sc->args = cdr(sc->args);
2487  s_goto(sc, OP_APPLY);
2488  }
2489 
2490 #if USE_TRACING
2491  case OP_TRACING:
2492  {
2493  int tr = sc->tracing;
2494  sc->tracing = ivalue(car(sc->args));
2495  s_return(sc, mk_integer(sc, tr));
2496  }
2497 #endif
2498 
2499  case OP_APPLY: /* apply 'code' to 'args' */
2500 #if USE_TRACING
2501  if (sc->tracing) {
2502  s_save(sc, OP_REAL_APPLY, sc->args, sc->code);
2503  sc->print_flag = 1;
2504  /* sc->args=cons(sc,sc->code,sc->args);*/
2505  putstr(sc, "\nApply to: ");
2506  s_goto(sc, OP_P0LIST);
2507  }
2508  /* fall through */
2509  case OP_REAL_APPLY:
2510 #endif
2511  if (is_proc(sc->code)) {
2512  s_goto(sc, procnum(sc->code)); /* PROCEDURE */
2513  } else if (is_foreign(sc->code)) {
2514  x = sc->code->_object._ff(sc, sc->args);
2515  s_return(sc, x);
2516  } else if (is_closure(sc->code) || is_macro(sc->code) || is_promise(sc->code)) { /* CLOSURE */
2517  /* Should not accept promise */
2518  /* make environment */
2519  new_frame_in_env(sc, closure_env(sc->code));
2520  for (x = car(closure_code(sc->code)), y = sc->args; is_pair(x); x = cdr(x), y = cdr(y)) {
2521  if (y == sc->NIL) {
2522  Error_0(sc, "not enough arguments");
2523  } else {
2524  new_slot_in_env(sc, car(x), car(y));
2525  }
2526  }
2527  if (x == sc->NIL) {
2528  /*--
2529  * if (y != sc->NIL) {
2530  * Error_0(sc,"too many arguments");
2531  * }
2532  */
2533  } else if (is_symbol(x))
2534  new_slot_in_env(sc, x, y);
2535  else {
2536  Error_1(sc, "syntax error in closure: not a symbol:", x);
2537  }
2538  sc->code = cdr(closure_code(sc->code));
2539  sc->args = sc->NIL;
2540  s_goto(sc, OP_BEGIN);
2541  } else if (is_continuation(sc->code)) { /* CONTINUATION */
2542  sc->dump = cont_dump(sc->code);
2543  s_return(sc, sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2544  } else {
2545  Error_0(sc, "illegal function");
2546  }
2547 
2548  case OP_DOMACRO: /* do macro */ sc->code = sc->value; s_goto(sc, OP_EVAL);
2549 
2550  case OP_LAMBDA: /* lambda */ s_return(sc, mk_closure(sc, sc->code, sc->envir));
2551 
2552  case OP_MKCLOSURE: /* make-closure */
2553  x = car(sc->args);
2554  if (car(x) == sc->LAMBDA) {
2555  x = cdr(x);
2556  }
2557  if (cdr(sc->args) == sc->NIL) {
2558  y = sc->envir;
2559  } else {
2560  y = cadr(sc->args);
2561  }
2562  s_return(sc, mk_closure(sc, x, y));
2563 
2564  case OP_QUOTE: /* quote */ x = car(sc->code); s_return(sc, car(sc->code));
2565 
2566  case OP_DEF0: /* define */
2567  if (is_pair(car(sc->code))) {
2568  x = caar(sc->code);
2569  sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2570  } else {
2571  x = car(sc->code);
2572  sc->code = cadr(sc->code);
2573  }
2574  if (!is_symbol(x)) {
2575  Error_0(sc, "variable is not a symbol");
2576  }
2577  s_save(sc, OP_DEF1, sc->NIL, x);
2578  s_goto(sc, OP_EVAL);
2579 
2580  case OP_DEF1: /* define */
2581  x = find_slot_in_env(sc, sc->envir, sc->code, 0);
2582  if (x != sc->NIL) {
2583  set_slot_in_env(sc, x, sc->value);
2584  } else {
2585  new_slot_in_env(sc, sc->code, sc->value);
2586  }
2587  s_return(sc, sc->code);
2588 
2589  case OP_DEFP: /* defined? */
2590  x = sc->envir;
2591  if (cdr(sc->args) != sc->NIL) {
2592  x = cadr(sc->args);
2593  }
2594  s_retbool(find_slot_in_env(sc, x, car(sc->args), 1) != sc->NIL);
2595 
2596  case OP_SET0: /* set! */
2597  s_save(sc, OP_SET1, sc->NIL, car(sc->code));
2598  sc->code = cadr(sc->code);
2599  s_goto(sc, OP_EVAL);
2600 
2601  case OP_SET1: /* set! */
2602  y = find_slot_in_env(sc, sc->envir, sc->code, 1);
2603  if (y != sc->NIL) {
2604  set_slot_in_env(sc, y, sc->value);
2605  s_return(sc, sc->value);
2606  } else {
2607  Error_1(sc, "set!: unbound variable:", sc->code);
2608  }
2609 
2610  case OP_BEGIN: /* begin */
2611  if (!is_pair(sc->code)) {
2612  s_return(sc, sc->code);
2613  }
2614  if (cdr(sc->code) != sc->NIL) {
2615  s_save(sc, OP_BEGIN, sc->NIL, cdr(sc->code));
2616  }
2617  sc->code = car(sc->code);
2618  s_goto(sc, OP_EVAL);
2619 
2620  case OP_IF0: /* if */
2621  s_save(sc, OP_IF1, sc->NIL, cdr(sc->code));
2622  sc->code = car(sc->code);
2623  s_goto(sc, OP_EVAL);
2624 
2625  case OP_IF1: /* if */
2626  if (is_true(sc->value))
2627  sc->code = car(sc->code);
2628  else
2629  sc->code = cadr(sc->code); /* (if #f 1) ==> () because
2630  * car(sc->NIL) = sc->NIL */
2631  s_goto(sc, OP_EVAL);
2632 
2633  case OP_LET0: /* let */
2634  sc->args = sc->NIL;
2635  sc->value = sc->code;
2636  sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2637  s_goto(sc, OP_LET1);
2638 
2639  case OP_LET1: /* let (calculate parameters) */
2640  sc->args = cons(sc, sc->value, sc->args);
2641  if (is_pair(sc->code)) { /* continue */
2642  s_save(sc, OP_LET1, sc->args, cdr(sc->code));
2643  sc->code = cadar(sc->code);
2644  sc->args = sc->NIL;
2645  s_goto(sc, OP_EVAL);
2646  } else { /* end */
2647  sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2648  sc->code = car(sc->args);
2649  sc->args = cdr(sc->args);
2650  s_goto(sc, OP_LET2);
2651  }
2652 
2653  case OP_LET2: /* let */
2654  new_frame_in_env(sc, sc->envir);
2655  for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; y != sc->NIL;
2656  x = cdr(x), y = cdr(y)) {
2657  new_slot_in_env(sc, caar(x), car(y));
2658  }
2659  if (is_symbol(car(sc->code))) { /* named let */
2660  for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2661 
2662  sc->args = cons(sc, caar(x), sc->args);
2663  }
2664  x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2665  new_slot_in_env(sc, car(sc->code), x);
2666  sc->code = cddr(sc->code);
2667  sc->args = sc->NIL;
2668  } else {
2669  sc->code = cdr(sc->code);
2670  sc->args = sc->NIL;
2671  }
2672  s_goto(sc, OP_BEGIN);
2673 
2674  case OP_LET0AST: /* let* */
2675  if (car(sc->code) == sc->NIL) {
2676  new_frame_in_env(sc, sc->envir);
2677  sc->code = cdr(sc->code);
2678  s_goto(sc, OP_BEGIN);
2679  }
2680  s_save(sc, OP_LET1AST, cdr(sc->code), car(sc->code));
2681  sc->code = cadaar(sc->code);
2682  s_goto(sc, OP_EVAL);
2683 
2684  case OP_LET1AST: /* let* (make new frame) */ new_frame_in_env(sc, sc->envir); s_goto(sc, OP_LET2AST);
2685 
2686  case OP_LET2AST: /* let* (calculate parameters) */
2687  new_slot_in_env(sc, caar(sc->code), sc->value);
2688  sc->code = cdr(sc->code);
2689  if (is_pair(sc->code)) { /* continue */
2690  s_save(sc, OP_LET2AST, sc->args, sc->code);
2691  sc->code = cadar(sc->code);
2692  sc->args = sc->NIL;
2693  s_goto(sc, OP_EVAL);
2694  } else { /* end */
2695  sc->code = sc->args;
2696  sc->args = sc->NIL;
2697  s_goto(sc, OP_BEGIN);
2698  }
2699  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
2700  }
2701  return sc->T;
2702 }
2703 
2704 static pointer
2705 opexe_1(scheme* sc, enum scheme_opcodes op) {
2706  pointer x, y;
2707 
2708  switch (op) {
2709  case OP_LET0REC: /* letrec */
2710  new_frame_in_env(sc, sc->envir);
2711  sc->args = sc->NIL;
2712  sc->value = sc->code;
2713  sc->code = car(sc->code);
2714  s_goto(sc, OP_LET1REC);
2715 
2716  case OP_LET1REC: /* letrec (calculate parameters) */
2717  sc->args = cons(sc, sc->value, sc->args);
2718  if (is_pair(sc->code)) { /* continue */
2719  s_save(sc, OP_LET1REC, sc->args, cdr(sc->code));
2720  sc->code = cadar(sc->code);
2721  sc->args = sc->NIL;
2722  s_goto(sc, OP_EVAL);
2723  } else { /* end */
2724  sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2725  sc->code = car(sc->args);
2726  sc->args = cdr(sc->args);
2727  s_goto(sc, OP_LET2REC);
2728  }
2729 
2730  case OP_LET2REC: /* letrec */
2731  for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2732  new_slot_in_env(sc, caar(x), car(y));
2733  }
2734  sc->code = cdr(sc->code);
2735  sc->args = sc->NIL;
2736  s_goto(sc, OP_BEGIN);
2737 
2738  case OP_COND0: /* cond */
2739  if (!is_pair(sc->code)) {
2740  Error_0(sc, "syntax error in cond");
2741  }
2742  s_save(sc, OP_COND1, sc->NIL, sc->code);
2743  sc->code = caar(sc->code);
2744  s_goto(sc, OP_EVAL);
2745 
2746  case OP_COND1: /* cond */
2747  if (is_true(sc->value)) {
2748  if ((sc->code = cdar(sc->code)) == sc->NIL) {
2749  s_return(sc, sc->value);
2750  }
2751  if (car(sc->code) == sc->FEED_TO) {
2752  if (!is_pair(cdr(sc->code))) {
2753  Error_0(sc, "syntax error in cond");
2754  }
2755  x = cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2756  sc->code = cons(sc, cadr(sc->code), cons(sc, x, sc->NIL));
2757  s_goto(sc, OP_EVAL);
2758  }
2759  s_goto(sc, OP_BEGIN);
2760  } else {
2761  if ((sc->code = cdr(sc->code)) == sc->NIL) {
2762  s_return(sc, sc->NIL);
2763  } else {
2764  s_save(sc, OP_COND1, sc->NIL, sc->code);
2765  sc->code = caar(sc->code);
2766  s_goto(sc, OP_EVAL);
2767  }
2768  }
2769 
2770  case OP_DELAY: /* delay */
2771  x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2772  typeflag(x) = T_PROMISE;
2773  s_return(sc, x);
2774 
2775  case OP_AND0: /* and */
2776  if (sc->code == sc->NIL) {
2777  s_return(sc, sc->T);
2778  }
2779  s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
2780  sc->code = car(sc->code);
2781  s_goto(sc, OP_EVAL);
2782 
2783  case OP_AND1: /* and */
2784  if (is_false(sc->value)) {
2785  s_return(sc, sc->value);
2786  } else if (sc->code == sc->NIL) {
2787  s_return(sc, sc->value);
2788  } else {
2789  s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
2790  sc->code = car(sc->code);
2791  s_goto(sc, OP_EVAL);
2792  }
2793 
2794  case OP_OR0: /* or */
2795  if (sc->code == sc->NIL) {
2796  s_return(sc, sc->F);
2797  }
2798  s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
2799  sc->code = car(sc->code);
2800  s_goto(sc, OP_EVAL);
2801 
2802  case OP_OR1: /* or */
2803  if (is_true(sc->value)) {
2804  s_return(sc, sc->value);
2805  } else if (sc->code == sc->NIL) {
2806  s_return(sc, sc->value);
2807  } else {
2808  s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
2809  sc->code = car(sc->code);
2810  s_goto(sc, OP_EVAL);
2811  }
2812 
2813  case OP_C0STREAM: /* cons-stream */
2814  s_save(sc, OP_C1STREAM, sc->NIL, cdr(sc->code));
2815  sc->code = car(sc->code);
2816  s_goto(sc, OP_EVAL);
2817 
2818  case OP_C1STREAM: /* cons-stream */
2819  sc->args = sc->value; /* save sc->value to register sc->args for gc */
2820  x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2821  typeflag(x) = T_PROMISE;
2822  s_return(sc, cons(sc, sc->args, x));
2823 
2824  case OP_MACRO0: /* macro */
2825  if (is_pair(car(sc->code))) {
2826  x = caar(sc->code);
2827  sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2828  } else {
2829  x = car(sc->code);
2830  sc->code = cadr(sc->code);
2831  }
2832  if (!is_symbol(x)) {
2833  Error_0(sc, "variable is not a symbol");
2834  }
2835  s_save(sc, OP_MACRO1, sc->NIL, x);
2836  s_goto(sc, OP_EVAL);
2837 
2838  case OP_MACRO1: /* macro */
2839  typeflag(sc->value) = T_MACRO;
2840  x = find_slot_in_env(sc, sc->envir, sc->code, 0);
2841  if (x != sc->NIL) {
2842  set_slot_in_env(sc, x, sc->value);
2843  } else {
2844  new_slot_in_env(sc, sc->code, sc->value);
2845  }
2846  s_return(sc, sc->code);
2847 
2848  case OP_CASE0: /* case */
2849  s_save(sc, OP_CASE1, sc->NIL, cdr(sc->code));
2850  sc->code = car(sc->code);
2851  s_goto(sc, OP_EVAL);
2852 
2853  case OP_CASE1: /* case */
2854  for (x = sc->code; x != sc->NIL; x = cdr(x)) {
2855  if (!is_pair(y = caar(x))) {
2856  break;
2857  }
2858  for (; y != sc->NIL; y = cdr(y)) {
2859  if (eqv(car(y), sc->value)) {
2860  break;
2861  }
2862  }
2863  if (y != sc->NIL) {
2864  break;
2865  }
2866  }
2867  if (x != sc->NIL) {
2868  if (is_pair(caar(x))) {
2869  sc->code = cdar(x);
2870  s_goto(sc, OP_BEGIN);
2871  } else { /* else */
2872  s_save(sc, OP_CASE2, sc->NIL, cdar(x));
2873  sc->code = caar(x);
2874  s_goto(sc, OP_EVAL);
2875  }
2876  } else {
2877  s_return(sc, sc->NIL);
2878  }
2879 
2880  case OP_CASE2: /* case */
2881  if (is_true(sc->value)) {
2882  s_goto(sc, OP_BEGIN);
2883  } else {
2884  s_return(sc, sc->NIL);
2885  }
2886 
2887  case OP_PAPPLY: /* apply */
2888  sc->code = car(sc->args);
2889  sc->args = list_star(sc, cdr(sc->args));
2890  /*sc->args = cadr(sc->args);*/
2891  s_goto(sc, OP_APPLY);
2892 
2893  case OP_PEVAL: /* eval */
2894  if (cdr(sc->args) != sc->NIL) {
2895  sc->envir = cadr(sc->args);
2896  }
2897  sc->code = car(sc->args);
2898  s_goto(sc, OP_EVAL);
2899 
2900  case OP_CONTINUATION: /* call-with-current-continuation */
2901  sc->code = car(sc->args);
2902  sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
2903  s_goto(sc, OP_APPLY);
2904 
2905  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
2906  }
2907  return sc->T;
2908 }
2909 
2910 static pointer
2911 opexe_2(scheme* sc, enum scheme_opcodes op) {
2912  pointer x;
2913  num v;
2914 #if USE_MATH
2915  double dd;
2916 #endif
2917 
2918  switch (op) {
2919 #if USE_MATH
2920  case OP_INEX2EX: /* inexact->exact */
2921  x = car(sc->args);
2922  if (is_integer(x)) {
2923  s_return(sc, x);
2924  } else if (modf(rvalue_unchecked(x), &dd) == 0.0) {
2925  s_return(sc, mk_integer(sc, ivalue(x)));
2926  } else {
2927  Error_1(sc, "inexact->exact: not integral:", x);
2928  }
2929 
2930  case OP_EXP: x = car(sc->args); s_return(sc, mk_real(sc, exp(rvalue(x))));
2931 
2932  case OP_LOG: x = car(sc->args); s_return(sc, mk_real(sc, log(rvalue(x))));
2933 
2934  case OP_SIN: x = car(sc->args); s_return(sc, mk_real(sc, sin(rvalue(x))));
2935 
2936  case OP_COS: x = car(sc->args); s_return(sc, mk_real(sc, cos(rvalue(x))));
2937 
2938  case OP_TAN: x = car(sc->args); s_return(sc, mk_real(sc, tan(rvalue(x))));
2939 
2940  case OP_ASIN: x = car(sc->args); s_return(sc, mk_real(sc, asin(rvalue(x))));
2941 
2942  case OP_ACOS: x = car(sc->args); s_return(sc, mk_real(sc, acos(rvalue(x))));
2943 
2944  case OP_ATAN:
2945  x = car(sc->args);
2946  if (cdr(sc->args) == sc->NIL) {
2947  s_return(sc, mk_real(sc, atan(rvalue(x))));
2948  } else {
2949  pointer y = cadr(sc->args);
2950  s_return(sc, mk_real(sc, atan2(rvalue(x), rvalue(y))));
2951  }
2952 
2953  case OP_SQRT: x = car(sc->args); s_return(sc, mk_real(sc, sqrt(rvalue(x))));
2954 
2955  case OP_EXPT:
2956  x = car(sc->args);
2957  if (cdr(sc->args) == sc->NIL) {
2958  Error_0(sc, "expt: needs two arguments");
2959  } else {
2960  pointer y = cadr(sc->args);
2961  s_return(sc, mk_real(sc, pow(rvalue(x), rvalue(y))));
2962  }
2963 
2964  case OP_FLOOR: x = car(sc->args); s_return(sc, mk_real(sc, floor(rvalue(x))));
2965 
2966  case OP_CEILING: x = car(sc->args); s_return(sc, mk_real(sc, ceil(rvalue(x))));
2967 
2968  case OP_TRUNCATE:
2969  {
2970  double rvalue_of_x;
2971  x = car(sc->args);
2972  rvalue_of_x = rvalue(x);
2973  if (rvalue_of_x > 0) {
2974  s_return(sc, mk_real(sc, floor(rvalue_of_x)));
2975  } else {
2976  s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
2977  }
2978  }
2979 
2980  case OP_ROUND: x = car(sc->args); s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
2981 #endif
2982 
2983  case OP_ADD: /* + */
2984  v = num_zero;
2985  for (x = sc->args; x != sc->NIL; x = cdr(x)) {
2986  v = num_add(v, nvalue(car(x)));
2987  }
2988  s_return(sc, mk_number(sc, v));
2989 
2990  case OP_MUL: /* * */
2991  v = num_one;
2992  for (x = sc->args; x != sc->NIL; x = cdr(x)) {
2993  v = num_mul(v, nvalue(car(x)));
2994  }
2995  s_return(sc, mk_number(sc, v));
2996 
2997  case OP_SUB: /* - */
2998  if (cdr(sc->args) == sc->NIL) {
2999  x = sc->args;
3000  v = num_zero;
3001  } else {
3002  x = cdr(sc->args);
3003  v = nvalue(car(sc->args));
3004  }
3005  for (; x != sc->NIL; x = cdr(x)) {
3006  v = num_sub(v, nvalue(car(x)));
3007  }
3008  s_return(sc, mk_number(sc, v));
3009 
3010  case OP_DIV: /* / */
3011  if (cdr(sc->args) == sc->NIL) {
3012  x = sc->args;
3013  v = num_one;
3014  } else {
3015  x = cdr(sc->args);
3016  v = nvalue(car(sc->args));
3017  }
3018  for (; x != sc->NIL; x = cdr(x)) {
3019  if (!is_zero_double(rvalue(car(x))))
3020  v = num_div(v, nvalue(car(x)));
3021  else {
3022  Error_0(sc, "/: division by zero");
3023  }
3024  }
3025  s_return(sc, mk_number(sc, v));
3026 
3027  case OP_INTDIV: /* quotient */
3028  if (cdr(sc->args) == sc->NIL) {
3029  x = sc->args;
3030  v = num_one;
3031  } else {
3032  x = cdr(sc->args);
3033  v = nvalue(car(sc->args));
3034  }
3035  for (; x != sc->NIL; x = cdr(x)) {
3036  if (ivalue(car(x)) != 0)
3037  v = num_intdiv(v, nvalue(car(x)));
3038  else {
3039  Error_0(sc, "quotient: division by zero");
3040  }
3041  }
3042  s_return(sc, mk_number(sc, v));
3043 
3044  case OP_REM: /* remainder */
3045  v = nvalue(car(sc->args));
3046  if (ivalue(cadr(sc->args)) != 0)
3047  v = num_rem(v, nvalue(cadr(sc->args)));
3048  else {
3049  Error_0(sc, "remainder: division by zero");
3050  }
3051  s_return(sc, mk_number(sc, v));
3052 
3053  case OP_MOD: /* modulo */
3054  v = nvalue(car(sc->args));
3055  if (ivalue(cadr(sc->args)) != 0)
3056  v = num_mod(v, nvalue(cadr(sc->args)));
3057  else {
3058  Error_0(sc, "modulo: division by zero");
3059  }
3060  s_return(sc, mk_number(sc, v));
3061 
3062  case OP_CAR: /* car */ s_return(sc, caar(sc->args));
3063 
3064  case OP_CDR: /* cdr */ s_return(sc, cdar(sc->args));
3065 
3066  case OP_CONS: /* cons */ cdr(sc->args) = cadr(sc->args); s_return(sc, sc->args);
3067 
3068  case OP_SETCAR: /* set-car! */
3069  if (!is_immutable(car(sc->args))) {
3070  caar(sc->args) = cadr(sc->args);
3071  s_return(sc, car(sc->args));
3072  } else {
3073  Error_0(sc, "set-car!: unable to alter immutable pair");
3074  }
3075 
3076  case OP_SETCDR: /* set-cdr! */
3077  if (!is_immutable(car(sc->args))) {
3078  cdar(sc->args) = cadr(sc->args);
3079  s_return(sc, car(sc->args));
3080  } else {
3081  Error_0(sc, "set-cdr!: unable to alter immutable pair");
3082  }
3083 
3084  case OP_CHAR2INT:
3085  { /* char->integer */
3086  char c;
3087  c = (char)ivalue(car(sc->args));
3088  s_return(sc, mk_integer(sc, (unsigned char)c));
3089  }
3090 
3091  case OP_INT2CHAR:
3092  { /* integer->char */
3093  unsigned char c;
3094  c = (unsigned char)ivalue(car(sc->args));
3095  s_return(sc, mk_character(sc, (char)c));
3096  }
3097 
3098  case OP_CHARUPCASE:
3099  {
3100  unsigned char c;
3101  c = (unsigned char)ivalue(car(sc->args));
3102  c = toupper(c);
3103  s_return(sc, mk_character(sc, (char)c));
3104  }
3105 
3106  case OP_CHARDNCASE:
3107  {
3108  unsigned char c;
3109  c = (unsigned char)ivalue(car(sc->args));
3110  c = tolower(c);
3111  s_return(sc, mk_character(sc, (char)c));
3112  }
3113 
3114  case OP_STR2SYM: /* string->symbol */ s_return(sc, mk_symbol(sc, strvalue(car(sc->args))));
3115 
3116  case OP_STR2ATOM: /* string->atom */
3117  {
3118  char* s = strvalue(car(sc->args));
3119  if (*s == '#') {
3120  s_return(sc, mk_sharp_const(sc, s + 1));
3121  } else {
3122  s_return(sc, mk_atom(sc, s));
3123  }
3124  }
3125 
3126  case OP_SYM2STR: /* symbol->string */
3127  x = mk_string(sc, symname(car(sc->args)));
3128  setimmutable(x);
3129  s_return(sc, x);
3130  case OP_ATOM2STR: /* atom->string */
3131  x = car(sc->args);
3132  if (is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3133  char* p;
3134  int len;
3135  atom2str(sc, x, 0, &p, &len);
3136  s_return(sc, mk_counted_string(sc, p, len));
3137  } else {
3138  Error_1(sc, "atom->string: not an atom:", x);
3139  }
3140 
3141  case OP_MKSTRING:
3142  { /* make-string */
3143  int fill = ' ';
3144  int len;
3145 
3146  len = ivalue(car(sc->args));
3147 
3148  if (cdr(sc->args) != sc->NIL) {
3149  fill = charvalue(cadr(sc->args));
3150  }
3151  s_return(sc, mk_empty_string(sc, len, (char)fill));
3152  }
3153 
3154  case OP_STRLEN: /* string-length */ s_return(sc, mk_integer(sc, strlength(car(sc->args))));
3155 
3156  case OP_STRREF:
3157  { /* string-ref */
3158  char* str;
3159  int index;
3160 
3161  str = strvalue(car(sc->args));
3162 
3163  index = ivalue(cadr(sc->args));
3164 
3165  if (index >= strlength(car(sc->args))) {
3166  Error_1(sc, "string-ref: out of bounds:", cadr(sc->args));
3167  }
3168 
3169  s_return(sc, mk_character(sc, ((unsigned char*)str)[index]));
3170  }
3171 
3172  case OP_STRSET:
3173  { /* string-set! */
3174  char* str;
3175  int index;
3176  int c;
3177 
3178  if (is_immutable(car(sc->args))) {
3179  Error_1(sc, "string-set!: unable to alter immutable string:", car(sc->args));
3180  }
3181  str = strvalue(car(sc->args));
3182 
3183  index = ivalue(cadr(sc->args));
3184  if (index >= strlength(car(sc->args))) {
3185  Error_1(sc, "string-set!: out of bounds:", cadr(sc->args));
3186  }
3187 
3188  c = charvalue(caddr(sc->args));
3189 
3190  str[index] = (char)c;
3191  s_return(sc, car(sc->args));
3192  }
3193 
3194  case OP_STRAPPEND:
3195  { /* string-append */
3196  /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3197  int len = 0;
3198  pointer newstr;
3199  char* pos;
3200 
3201  /* compute needed length for new string */
3202  for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3203  len += strlength(car(x));
3204  }
3205  newstr = mk_empty_string(sc, len, ' ');
3206  /* store the contents of the argument strings into the new string */
3207  for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; pos += strlength(car(x)), x = cdr(x)) {
3208  memcpy(pos, strvalue(car(x)), strlength(car(x)));
3209  }
3210  s_return(sc, newstr);
3211  }
3212 
3213  case OP_SUBSTR:
3214  { /* substring */
3215  char* str;
3216  int index0;
3217  int index1;
3218  int len;
3219 
3220  str = strvalue(car(sc->args));
3221 
3222  index0 = ivalue(cadr(sc->args));
3223 
3224  if (index0 > strlength(car(sc->args))) {
3225  Error_1(sc, "substring: start out of bounds:", cadr(sc->args));
3226  }
3227 
3228  if (cddr(sc->args) != sc->NIL) {
3229  index1 = ivalue(caddr(sc->args));
3230  if (index1 > strlength(car(sc->args)) || index1 < index0) {
3231  Error_1(sc, "substring: end out of bounds:", caddr(sc->args));
3232  }
3233  } else {
3234  index1 = strlength(car(sc->args));
3235  }
3236 
3237  len = index1 - index0;
3238  x = mk_empty_string(sc, len, ' ');
3239  memcpy(strvalue(x), str + index0, len);
3240  strvalue(x)[len] = 0;
3241 
3242  s_return(sc, x);
3243  }
3244 
3245  case OP_VECTOR:
3246  { /* vector */
3247  int i;
3248  pointer vec;
3249  int len = list_length(sc, sc->args);
3250  if (len < 0) {
3251  Error_1(sc, "vector: not a proper list:", sc->args);
3252  }
3253  vec = mk_vector(sc, len);
3254  for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3255  set_vector_elem(vec, i, car(x));
3256  }
3257  s_return(sc, vec);
3258  }
3259 
3260  case OP_MKVECTOR:
3261  { /* make-vector */
3262  pointer fill = sc->NIL;
3263  int len;
3264  pointer vec;
3265 
3266  len = ivalue(car(sc->args));
3267 
3268  if (cdr(sc->args) != sc->NIL) {
3269  fill = cadr(sc->args);
3270  }
3271  vec = mk_vector(sc, len);
3272  if (fill != sc->NIL) {
3273  fill_vector(vec, fill);
3274  }
3275  s_return(sc, vec);
3276  }
3277 
3278  case OP_VECLEN: /* vector-length */ s_return(sc, mk_integer(sc, ivalue(car(sc->args))));
3279 
3280  case OP_VECREF:
3281  { /* vector-ref */
3282  int index;
3283 
3284  index = ivalue(cadr(sc->args));
3285 
3286  if (index >= ivalue(car(sc->args))) {
3287  Error_1(sc, "vector-ref: out of bounds:", cadr(sc->args));
3288  }
3289 
3290  s_return(sc, vector_elem(car(sc->args), index));
3291  }
3292 
3293  case OP_VECSET:
3294  { /* vector-set! */
3295  int index;
3296 
3297  if (is_immutable(car(sc->args))) {
3298  Error_1(sc, "vector-set!: unable to alter immutable vector:", car(sc->args));
3299  }
3300 
3301  index = ivalue(cadr(sc->args));
3302  if (index >= ivalue(car(sc->args))) {
3303  Error_1(sc, "vector-set!: out of bounds:", cadr(sc->args));
3304  }
3305 
3306  set_vector_elem(car(sc->args), index, caddr(sc->args));
3307  s_return(sc, car(sc->args));
3308  }
3309 
3310  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3311  }
3312  return sc->T;
3313 }
3314 
3315 static int
3316 list_length(scheme* sc, pointer a) {
3317  int v = 0;
3318  pointer x;
3319  for (x = a, v = 0; is_pair(x); x = cdr(x)) {
3320  ++v;
3321  }
3322  if (x == sc->NIL) {
3323  return v;
3324  }
3325  return -1;
3326 }
3327 
3328 static pointer
3329 opexe_3(scheme* sc, enum scheme_opcodes op) {
3330  pointer x;
3331  num v;
3332  int (*comp_func)(num, num) = 0;
3333 
3334  switch (op) {
3335  case OP_NOT: /* not */ s_retbool(is_false(car(sc->args)));
3336  case OP_BOOLP: /* boolean? */ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3337  case OP_EOFOBJP: /* boolean? */ s_retbool(car(sc->args) == sc->EOF_OBJ);
3338  case OP_NULLP: /* null? */ s_retbool(car(sc->args) == sc->NIL);
3339  case OP_NUMEQ: /* = */
3340  case OP_LESS: /* < */
3341  case OP_GRE: /* > */
3342  case OP_LEQ: /* <= */
3343  case OP_GEQ: /* >= */
3344  switch (op) {
3345  case OP_NUMEQ: comp_func = num_eq; break;
3346  case OP_LESS: comp_func = num_lt; break;
3347  case OP_GRE: comp_func = num_gt; break;
3348  case OP_LEQ: comp_func = num_le; break;
3349  case OP_GEQ: comp_func = num_ge; break;
3350  default:;
3351  }
3352  x = sc->args;
3353  v = nvalue(car(x));
3354  x = cdr(x);
3355 
3356  for (; x != sc->NIL; x = cdr(x)) {
3357  if (!comp_func(v, nvalue(car(x)))) {
3358  s_retbool(0);
3359  }
3360  v = nvalue(car(x));
3361  }
3362  s_retbool(1);
3363  case OP_SYMBOLP: /* symbol? */ s_retbool(is_symbol(car(sc->args)));
3364  case OP_NUMBERP: /* number? */ s_retbool(is_number(car(sc->args)));
3365  case OP_STRINGP: /* string? */ s_retbool(is_string(car(sc->args)));
3366  case OP_INTEGERP: /* integer? */ s_retbool(is_integer(car(sc->args)));
3367  case OP_REALP: /* real? */ s_retbool(is_number(car(sc->args))); /* All numbers are real */
3368  case OP_CHARP: /* char? */ s_retbool(is_character(car(sc->args)));
3369 #if USE_CHAR_CLASSIFIERS
3370  case OP_CHARAP: /* char-alphabetic? */ s_retbool(Cisalpha(ivalue(car(sc->args))));
3371  case OP_CHARNP: /* char-numeric? */ s_retbool(Cisdigit(ivalue(car(sc->args))));
3372  case OP_CHARWP: /* char-whitespace? */ s_retbool(Cisspace(ivalue(car(sc->args))));
3373  case OP_CHARUP: /* char-upper-case? */ s_retbool(Cisupper(ivalue(car(sc->args))));
3374  case OP_CHARLP: /* char-lower-case? */ s_retbool(Cislower(ivalue(car(sc->args))));
3375 #endif
3376  case OP_PORTP: /* port? */ s_retbool(is_port(car(sc->args)));
3377  case OP_INPORTP: /* input-port? */ s_retbool(is_inport(car(sc->args)));
3378  case OP_OUTPORTP: /* output-port? */ s_retbool(is_outport(car(sc->args)));
3379  case OP_PROCP: /* procedure? */
3380  /*--
3381  * continuation should be procedure by the example
3382  * (call-with-current-continuation procedure?) ==> #t
3383  * in R^3 report sec. 6.9
3384  */
3385  s_retbool(
3386  is_proc(car(sc->args)) || is_closure(car(sc->args)) || is_continuation(car(sc->args))
3387  || is_foreign(car(sc->args))
3388  );
3389  case OP_PAIRP: /* pair? */ s_retbool(is_pair(car(sc->args)));
3390  case OP_LISTP:
3391  { /* list? */
3392  pointer slow, fast;
3393  slow = fast = car(sc->args);
3394  while (1) {
3395  if (!is_pair(fast))
3396  s_retbool(fast == sc->NIL);
3397  fast = cdr(fast);
3398  if (!is_pair(fast))
3399  s_retbool(fast == sc->NIL);
3400  fast = cdr(fast);
3401  slow = cdr(slow);
3402  if (fast == slow) {
3403  /* the fast pointer has looped back around and caught up
3404  with the slow pointer, hence the structure is circular,
3405  not of finite length, and therefore not a list */
3406  s_retbool(0);
3407  }
3408  }
3409  }
3410  case OP_ENVP: /* environment? */ s_retbool(is_environment(car(sc->args)));
3411  case OP_VECTORP: /* vector? */ s_retbool(is_vector(car(sc->args)));
3412  case OP_EQ: /* eq? */ s_retbool(car(sc->args) == cadr(sc->args));
3413  case OP_EQV: /* eqv? */ s_retbool(eqv(car(sc->args), cadr(sc->args)));
3414  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3415  }
3416  return sc->T;
3417 }
3418 
3419 static pointer
3420 opexe_4(scheme* sc, enum scheme_opcodes op) {
3421  pointer x, y;
3422 
3423  switch (op) {
3424  case OP_FORCE: /* force */
3425  sc->code = car(sc->args);
3426  if (is_promise(sc->code)) {
3427  /* Should change type to closure here */
3428  s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3429  sc->args = sc->NIL;
3430  s_goto(sc, OP_APPLY);
3431  } else {
3432  s_return(sc, sc->code);
3433  }
3434 
3435  case OP_SAVE_FORCED: /* Save forced value replacing promise */
3436  memcpy(sc->code, sc->value, sizeof(struct cell));
3437  s_return(sc, sc->value);
3438 
3439  case OP_WRITE: /* write */
3440  case OP_DISPLAY: /* display */
3441  case OP_WRITE_CHAR: /* write-char */
3442  if (is_pair(cdr(sc->args))) {
3443  if (cadr(sc->args) != sc->outport) {
3444  x = cons(sc, sc->outport, sc->NIL);
3445  s_save(sc, OP_SET_OUTPORT, x, sc->NIL);
3446  sc->outport = cadr(sc->args);
3447  }
3448  }
3449  sc->args = car(sc->args);
3450  if (op == OP_WRITE) {
3451  sc->print_flag = 1;
3452  } else {
3453  sc->print_flag = 0;
3454  }
3455  s_goto(sc, OP_P0LIST);
3456 
3457  case OP_NEWLINE: /* newline */
3458  if (is_pair(sc->args)) {
3459  if (car(sc->args) != sc->outport) {
3460  x = cons(sc, sc->outport, sc->NIL);
3461  s_save(sc, OP_SET_OUTPORT, x, sc->NIL);
3462  sc->outport = car(sc->args);
3463  }
3464  }
3465  putstr(sc, "\n");
3466  s_return(sc, sc->T);
3467 
3468  case OP_ERR0: /* error */
3469  sc->retcode = -1;
3470  if (!is_string(car(sc->args))) {
3471  sc->args = cons(sc, mk_string(sc, " -- "), sc->args);
3472  setimmutable(car(sc->args));
3473  }
3474  putstr(sc, "Error: ");
3475  putstr(sc, strvalue(car(sc->args)));
3476  sc->args = cdr(sc->args);
3477  s_goto(sc, OP_ERR1);
3478 
3479  case OP_ERR1: /* error */
3480  putstr(sc, " ");
3481  if (sc->args != sc->NIL) {
3482  s_save(sc, OP_ERR1, cdr(sc->args), sc->NIL);
3483  sc->args = car(sc->args);
3484  sc->print_flag = 1;
3485  s_goto(sc, OP_P0LIST);
3486  } else {
3487  putstr(sc, "\n");
3488  if (sc->interactive_repl) {
3489  s_goto(sc, OP_T0LVL);
3490  } else {
3491  return sc->NIL;
3492  }
3493  }
3494 
3495  case OP_REVERSE: /* reverse */ s_return(sc, reverse(sc, car(sc->args)));
3496 
3497  case OP_LIST_STAR: /* list* */ s_return(sc, list_star(sc, sc->args));
3498 
3499  case OP_APPEND: /* append */
3500  if (sc->args == sc->NIL) {
3501  s_return(sc, sc->NIL);
3502  }
3503  x = car(sc->args);
3504  if (cdr(sc->args) == sc->NIL) {
3505  s_return(sc, sc->args);
3506  }
3507  for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
3508  x = append(sc, x, car(y));
3509  }
3510  s_return(sc, x);
3511 
3512 #if USE_PLIST
3513  case OP_PUT: /* put */
3514  if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3515  Error_0(sc, "illegal use of put");
3516  }
3517  for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3518  if (caar(x) == y) {
3519  break;
3520  }
3521  }
3522  if (x != sc->NIL)
3523  cdar(x) = caddr(sc->args);
3524  else
3525  symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), symprop(car(sc->args)));
3526  s_return(sc, sc->T);
3527 
3528  case OP_GET: /* get */
3529  if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3530  Error_0(sc, "illegal use of get");
3531  }
3532  for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3533  if (caar(x) == y) {
3534  break;
3535  }
3536  }
3537  if (x != sc->NIL) {
3538  s_return(sc, cdar(x));
3539  } else {
3540  s_return(sc, sc->NIL);
3541  }
3542 #endif /* USE_PLIST */
3543  case OP_QUIT: /* quit */
3544  if (is_pair(sc->args)) {
3545  sc->retcode = ivalue(car(sc->args));
3546  }
3547  return (sc->NIL);
3548 
3549  case OP_GC: /* gc */ gc(sc, sc->NIL, sc->NIL); s_return(sc, sc->T);
3550 
3551  case OP_GCVERB: /* gc-verbose */
3552  {
3553  int was = sc->gc_verbose;
3554 
3555  sc->gc_verbose = (car(sc->args) != sc->F);
3556  s_retbool(was);
3557  }
3558 
3559  case OP_NEWSEGMENT: /* new-segment */
3560  if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3561  Error_0(sc, "new-segment: argument must be a number");
3562  }
3563  alloc_cellseg(sc, (int)ivalue(car(sc->args)));
3564  s_return(sc, sc->T);
3565 
3566  case OP_OBLIST: /* oblist */ s_return(sc, oblist_all_symbols(sc));
3567 
3568  case OP_CURR_INPORT: /* current-input-port */ s_return(sc, sc->inport);
3569 
3570  case OP_CURR_OUTPORT: /* current-output-port */ s_return(sc, sc->outport);
3571 
3572  case OP_OPEN_INFILE: /* open-input-file */
3573  case OP_OPEN_OUTFILE: /* open-output-file */
3574  case OP_OPEN_INOUTFILE: /* open-input-output-file */
3575  {
3576  int prop = 0;
3577  pointer p;
3578  switch (op) {
3579  case OP_OPEN_INFILE: prop = port_input; break;
3580  case OP_OPEN_OUTFILE: prop = port_output; break;
3581  case OP_OPEN_INOUTFILE: prop = port_input | port_output; break;
3582  default:;
3583  }
3584  p = port_from_filename(sc, strvalue(car(sc->args)), prop);
3585  if (p == sc->NIL) {
3586  s_return(sc, sc->F);
3587  }
3588  s_return(sc, p);
3589  }
3590 
3591 #if USE_STRING_PORTS
3592  case OP_OPEN_INSTRING: /* open-input-string */
3593  case OP_OPEN_OUTSTRING: /* open-output-string */
3594  case OP_OPEN_INOUTSTRING: /* open-input-output-string */
3595  {
3596  int prop = 0;
3597  pointer p;
3598  switch (op) {
3599  case OP_OPEN_INSTRING: prop = port_input; break;
3600  case OP_OPEN_OUTSTRING: prop = port_output; break;
3601  case OP_OPEN_INOUTSTRING: prop = port_input | port_output; break;
3602  default:;
3603  }
3604  p = port_from_string(
3605  sc, strvalue(car(sc->args)), strvalue(car(sc->args)) + strlength(car(sc->args)), prop
3606  );
3607  if (p == sc->NIL) {
3608  s_return(sc, sc->F);
3609  }
3610  s_return(sc, p);
3611  }
3612 #endif
3613 
3614  case OP_CLOSE_INPORT: /* close-input-port */ port_close(sc, car(sc->args), port_input); s_return(sc, sc->T);
3615 
3616  case OP_CLOSE_OUTPORT: /* close-output-port */ port_close(sc, car(sc->args), port_output); s_return(sc, sc->T);
3617 
3618  case OP_INT_ENV: /* interaction-environment */ s_return(sc, sc->global_env);
3619 
3620  case OP_CURR_ENV: /* current-environment */ s_return(sc, sc->envir);
3621  default:;
3622  }
3623  return sc->T;
3624 }
3625 
3626 static pointer
3627 opexe_5(scheme* sc, enum scheme_opcodes op) {
3628  pointer x;
3629 
3630  if (sc->nesting != 0) {
3631  int n = sc->nesting;
3632  sc->nesting = 0;
3633  sc->retcode = -1;
3634  Error_1(sc, "unmatched parentheses:", mk_integer(sc, n));
3635  }
3636 
3637  switch (op) {
3638  /* ========== reading part ========== */
3639  case OP_READ:
3640  if (!is_pair(sc->args)) {
3641  s_goto(sc, OP_READ_INTERNAL);
3642  }
3643  if (!is_inport(car(sc->args))) {
3644  Error_1(sc, "read: not an input port:", car(sc->args));
3645  }
3646  if (car(sc->args) == sc->inport) {
3647  s_goto(sc, OP_READ_INTERNAL);
3648  }
3649  x = sc->inport;
3650  sc->inport = car(sc->args);
3651  x = cons(sc, x, sc->NIL);
3652  s_save(sc, OP_SET_INPORT, x, sc->NIL);
3653  s_goto(sc, OP_READ_INTERNAL);
3654 
3655  case OP_READ_CHAR: /* read-char */
3656  case OP_PEEK_CHAR: /* peek-char */
3657  {
3658  int c;
3659  if (is_pair(sc->args)) {
3660  if (car(sc->args) != sc->inport) {
3661  x = sc->inport;
3662  x = cons(sc, x, sc->NIL);
3663  s_save(sc, OP_SET_INPORT, x, sc->NIL);
3664  sc->inport = car(sc->args);
3665  }
3666  }
3667  c = inchar(sc);
3668  if (c == EOF) {
3669  s_return(sc, sc->EOF_OBJ);
3670  }
3671  if (sc->op == OP_PEEK_CHAR) {
3672  backchar(sc, c);
3673  }
3674  s_return(sc, mk_character(sc, c));
3675  }
3676 
3677  case OP_CHAR_READY: /* char-ready? */
3678  {
3679  pointer p = sc->inport;
3680  int res;
3681  if (is_pair(sc->args)) {
3682  p = car(sc->args);
3683  }
3684  res = p->_object._port->kind & port_string;
3685  s_retbool(res);
3686  }
3687 
3688  case OP_SET_INPORT: /* set-input-port */ sc->inport = car(sc->args); s_return(sc, sc->value);
3689 
3690  case OP_SET_OUTPORT: /* set-output-port */ sc->outport = car(sc->args); s_return(sc, sc->value);
3691 
3692  case OP_RDSEXPR:
3693  switch (sc->tok) {
3694  case TOK_EOF:
3695  if (sc->inport == sc->loadport) {
3696  sc->args = sc->NIL;
3697  s_goto(sc, OP_QUIT);
3698  } else {
3699  s_return(sc, sc->EOF_OBJ);
3700  }
3701  case TOK_COMMENT:
3702  {
3703  int c;
3704  while ((c = inchar(sc)) != '\n' && c != EOF)
3705  ;
3706  sc->tok = token(sc);
3707  s_goto(sc, OP_RDSEXPR);
3708  }
3709  case TOK_VEC:
3710  s_save(sc, OP_RDVEC, sc->NIL, sc->NIL);
3711  /* fall through */
3712  case TOK_LPAREN:
3713  sc->tok = token(sc);
3714  if (sc->tok == TOK_RPAREN) {
3715  s_return(sc, sc->NIL);
3716  } else if (sc->tok == TOK_DOT) {
3717  Error_0(sc, "syntax error: illegal dot expression");
3718  } else {
3719  sc->nesting_stack[sc->file_i]++;
3720  s_save(sc, OP_RDLIST, sc->NIL, sc->NIL);
3721  s_goto(sc, OP_RDSEXPR);
3722  }
3723  case TOK_QUOTE:
3724  s_save(sc, OP_RDQUOTE, sc->NIL, sc->NIL);
3725  sc->tok = token(sc);
3726  s_goto(sc, OP_RDSEXPR);
3727  case TOK_BQUOTE:
3728  sc->tok = token(sc);
3729  if (sc->tok == TOK_VEC) {
3730  s_save(sc, OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
3731  sc->tok = TOK_LPAREN;
3732  s_goto(sc, OP_RDSEXPR);
3733  } else {
3734  s_save(sc, OP_RDQQUOTE, sc->NIL, sc->NIL);
3735  }
3736  s_goto(sc, OP_RDSEXPR);
3737  case TOK_COMMA:
3738  s_save(sc, OP_RDUNQUOTE, sc->NIL, sc->NIL);
3739  sc->tok = token(sc);
3740  s_goto(sc, OP_RDSEXPR);
3741  case TOK_ATMARK:
3742  s_save(sc, OP_RDUQTSP, sc->NIL, sc->NIL);
3743  sc->tok = token(sc);
3744  s_goto(sc, OP_RDSEXPR);
3745  case TOK_ATOM: s_return(sc, mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
3746  case TOK_DQUOTE:
3747  x = readstrexp(sc);
3748  if (x == sc->F) {
3749  Error_0(sc, "Error reading string");
3750  }
3751  setimmutable(x);
3752  s_return(sc, x);
3753  case TOK_SHARP:
3754  {
3755  pointer f = find_slot_in_env(sc, sc->envir, sc->SHARP_HOOK, 1);
3756  if (f == sc->NIL) {
3757  Error_0(sc, "undefined sharp expression");
3758  } else {
3759  sc->code = cons(sc, slot_value_in_env(f), sc->NIL);
3760  s_goto(sc, OP_EVAL);
3761  }
3762  }
3763  case TOK_SHARP_CONST:
3764  if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) {
3765  Error_0(sc, "undefined sharp expression");
3766  } else {
3767  s_return(sc, x);
3768  }
3769  default: Error_0(sc, "syntax error: illegal token");
3770  }
3771  break;
3772 
3773  case OP_RDLIST:
3774  {
3775  sc->args = cons(sc, sc->value, sc->args);
3776  sc->tok = token(sc);
3777  if (sc->tok == TOK_COMMENT) {
3778  int c;
3779  while ((c = inchar(sc)) != '\n' && c != EOF)
3780  ;
3781  sc->tok = token(sc);
3782  }
3783  if (sc->tok == TOK_RPAREN) {
3784  int c = inchar(sc);
3785  if (c != '\n')
3786  backchar(sc, c);
3787  sc->nesting_stack[sc->file_i]--;
3788  s_return(sc, reverse_in_place(sc, sc->NIL, sc->args));
3789  } else if (sc->tok == TOK_DOT) {
3790  s_save(sc, OP_RDDOT, sc->args, sc->NIL);
3791  sc->tok = token(sc);
3792  s_goto(sc, OP_RDSEXPR);
3793  } else {
3794  s_save(sc, OP_RDLIST, sc->args, sc->NIL);
3795  ;
3796  s_goto(sc, OP_RDSEXPR);
3797  }
3798  }
3799 
3800  case OP_RDDOT:
3801  if (token(sc) != TOK_RPAREN) {
3802  Error_0(sc, "syntax error: illegal dot expression");
3803  } else {
3804  sc->nesting_stack[sc->file_i]--;
3805  s_return(sc, reverse_in_place(sc, sc->value, sc->args));
3806  }
3807 
3808  case OP_RDQUOTE: s_return(sc, cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
3809 
3810  case OP_RDQQUOTE: s_return(sc, cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
3811 
3812  case OP_RDQQUOTEVEC:
3813  s_return(
3814  sc, cons(
3815  sc, mk_symbol(sc, "apply"),
3816  cons(
3817  sc, mk_symbol(sc, "vector"),
3818  cons(sc, cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)), sc->NIL)
3819  )
3820  )
3821  );
3822 
3823  case OP_RDUNQUOTE: s_return(sc, cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
3824 
3825  case OP_RDUQTSP: s_return(sc, cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
3826 
3827  case OP_RDVEC:
3828  /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
3829  s_goto(sc,OP_EVAL); Cannot be quoted*/
3830  /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
3831  s_return(sc,x); Cannot be part of pairs*/
3832  /*sc->code=mk_proc(sc,OP_VECTOR);
3833  sc->args=sc->value;
3834  s_goto(sc,OP_APPLY);*/
3835  sc->args = sc->value;
3836  s_goto(sc, OP_VECTOR);
3837 
3838  /* ========== printing part ========== */
3839  case OP_P0LIST:
3840  if (is_vector(sc->args)) {
3841  putstr(sc, "#(");
3842  sc->args = cons(sc, sc->args, mk_integer(sc, 0));
3843  s_goto(sc, OP_PVECFROM);
3844  } else if (is_environment(sc->args)) {
3845  putstr(sc, "#<ENVIRONMENT>");
3846  s_return(sc, sc->T);
3847  } else if (!is_pair(sc->args)) {
3848  printatom(sc, sc->args, sc->print_flag);
3849  s_return(sc, sc->T);
3850  } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
3851  putstr(sc, "'");
3852  sc->args = cadr(sc->args);
3853  s_goto(sc, OP_P0LIST);
3854  } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
3855  putstr(sc, "`");
3856  sc->args = cadr(sc->args);
3857  s_goto(sc, OP_P0LIST);
3858  } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
3859  putstr(sc, ",");
3860  sc->args = cadr(sc->args);
3861  s_goto(sc, OP_P0LIST);
3862  } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
3863  putstr(sc, ",@");
3864  sc->args = cadr(sc->args);
3865  s_goto(sc, OP_P0LIST);
3866  } else {
3867  putstr(sc, "(");
3868  s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
3869  sc->args = car(sc->args);
3870  s_goto(sc, OP_P0LIST);
3871  }
3872 
3873  case OP_P1LIST:
3874  if (is_pair(sc->args)) {
3875  s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
3876  putstr(sc, " ");
3877  sc->args = car(sc->args);
3878  s_goto(sc, OP_P0LIST);
3879  } else if (is_vector(sc->args)) {
3880  s_save(sc, OP_P1LIST, sc->NIL, sc->NIL);
3881  putstr(sc, " . ");
3882  s_goto(sc, OP_P0LIST);
3883  } else {
3884  if (sc->args != sc->NIL) {
3885  putstr(sc, " . ");
3886  printatom(sc, sc->args, sc->print_flag);
3887  }
3888  putstr(sc, ")");
3889  s_return(sc, sc->T);
3890  }
3891  case OP_PVECFROM:
3892  {
3893  int i = ivalue_unchecked(cdr(sc->args));
3894  pointer vec = car(sc->args);
3895  int len = ivalue_unchecked(vec);
3896  if (i == len) {
3897  putstr(sc, ")");
3898  s_return(sc, sc->T);
3899  } else {
3900  pointer elem = vector_elem(vec, i);
3901  ivalue_unchecked(cdr(sc->args)) = i + 1;
3902  s_save(sc, OP_PVECFROM, sc->args, sc->NIL);
3903  sc->args = elem;
3904  putstr(sc, " ");
3905  s_goto(sc, OP_P0LIST);
3906  }
3907  }
3908 
3909  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3910  }
3911  return sc->T;
3912 }
3913 
3914 static pointer
3915 opexe_6(scheme* sc, enum scheme_opcodes op) {
3916  pointer x, y;
3917  long v;
3918 
3919  switch (op) {
3920  case OP_LIST_LENGTH: /* length */ /* a.k */
3921  v = list_length(sc, car(sc->args));
3922  if (v < 0) {
3923  Error_1(sc, "length: not a list:", car(sc->args));
3924  }
3925  s_return(sc, mk_integer(sc, v));
3926 
3927  case OP_ASSQ: /* assq */ /* a.k */
3928  x = car(sc->args);
3929  for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
3930  if (!is_pair(car(y))) {
3931  Error_0(sc, "unable to handle non pair element");
3932  }
3933  if (x == caar(y))
3934  break;
3935  }
3936  if (is_pair(y)) {
3937  s_return(sc, car(y));
3938  } else {
3939  s_return(sc, sc->F);
3940  }
3941 
3942  case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
3943  sc->args = car(sc->args);
3944  if (sc->args == sc->NIL) {
3945  s_return(sc, sc->F);
3946  } else if (is_closure(sc->args)) {
3947  s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
3948  } else if (is_macro(sc->args)) {
3949  s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
3950  } else {
3951  s_return(sc, sc->F);
3952  }
3953  case OP_CLOSUREP: /* closure? */
3954  /*
3955  * Note, macro object is also a closure.
3956  * Therefore, (closure? <#MACRO>) ==> #t
3957  */
3958  s_retbool(is_closure(car(sc->args)));
3959  case OP_MACROP: /* macro? */ s_retbool(is_macro(car(sc->args)));
3960  default: sprintf(sc->strbuff, "%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3961  }
3962  return sc->T; /* NOTREACHED */
3963 }
3964 
3965 typedef pointer (*dispatch_func)(scheme*, enum scheme_opcodes);
3966 
3967 typedef int (*test_predicate)(pointer);
3968 
3969 static int
3970 is_any(pointer p) {
3971  return 1;
3972 }
3973 
3974 static int
3975 is_num_integer(pointer p) {
3976  return is_number(p) && ((p)->_object._number.is_fixnum);
3977 }
3978 
3979 static int
3980 is_nonneg(pointer p) {
3981  return is_num_integer(p) && ivalue(p) >= 0;
3982 }
3983 
3984 /* Correspond carefully with following defines! */
3985 static struct {
3986  test_predicate fct;
3987  const char* kind;
3988 } tests[] = {
3989  { 0, 0}, /* unused */
3990  { is_any, 0},
3991  { is_string, "string"},
3992  { is_symbol, "symbol"},
3993  { is_port, "port"},
3994  { 0, "input port"},
3995  { 0, "output_port"},
3996  {is_environment, "environment"},
3997  { is_pair, "pair"},
3998  { 0, "pair or '()"},
3999  { is_character, "character"},
4000  { is_vector, "vector"},
4001  { is_number, "number"},
4002  {is_num_integer, "integer"},
4003  { is_nonneg, "non-negative integer"}
4004 };
4005 
4006 #define TST_NONE 0
4007 #define TST_ANY "\001"
4008 #define TST_STRING "\002"
4009 #define TST_SYMBOL "\003"
4010 #define TST_PORT "\004"
4011 #define TST_INPORT "\005"
4012 #define TST_OUTPORT "\006"
4013 #define TST_ENVIRONMENT "\007"
4014 #define TST_PAIR "\010"
4015 #define TST_LIST "\011"
4016 #define TST_CHAR "\012"
4017 #define TST_VECTOR "\013"
4018 #define TST_NUMBER "\014"
4019 #define TST_INTEGER "\015"
4020 #define TST_NATURAL "\016"
4021 
4022 typedef struct {
4023  dispatch_func func;
4024  char* name;
4025  int min_arity;
4026  int max_arity;
4027  char* arg_tests_encoding;
4028 } op_code_info;
4029 
4030 #define INF_ARG 0xffff
4031 
4032 static op_code_info dispatch_table[] = {
4033 #define _OP_DEF(A, B, C, D, E, OP) { A, B, C, D, E },
4034 #include "opdefines.h"
4035  { 0 }
4036 };
4037 
4038 static const char*
4039 procname(pointer x) {
4040  int n = procnum(x);
4041  const char* name = dispatch_table[n].name;
4042  if (name == 0) {
4043  name = "ILLEGAL!";
4044  }
4045  return name;
4046 }
4047 
4048 /* kernel of this interpreter */
4049 static void
4050 Eval_Cycle(scheme* sc, enum scheme_opcodes op) {
4051  int count = 0;
4052  /*int old_op;*/
4053 
4054  sc->op = op;
4055  for (;;) {
4056  op_code_info* pcd = dispatch_table + sc->op;
4057  if (pcd->name != 0) { /* if built-in function, check arguments */
4058  char msg[512];
4059  int ok = 1;
4060  int n = list_length(sc, sc->args);
4061 
4062  /* Check number of arguments */
4063  if (n < pcd->min_arity) {
4064  ok = 0;
4065  sprintf(
4066  msg, "%s: needs%s %d argument(s)", pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least",
4067  pcd->min_arity
4068  );
4069  }
4070  if (ok && n > pcd->max_arity) {
4071  ok = 0;
4072  sprintf(
4073  msg, "%s: needs%s %d argument(s)", pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most",
4074  pcd->max_arity
4075  );
4076  }
4077  if (ok) {
4078  if (pcd->arg_tests_encoding != 0) {
4079  int i = 0;
4080  int j;
4081  const char* t = pcd->arg_tests_encoding;
4082  pointer arglist = sc->args;
4083  do {
4084  pointer arg = car(arglist);
4085  j = (int)t[0];
4086  if (j == TST_INPORT[0]) {
4087  if (!is_inport(arg))
4088  break;
4089  } else if (j == TST_OUTPORT[0]) {
4090  if (!is_outport(arg))
4091  break;
4092  } else if (j == TST_LIST[0]) {
4093  if (arg != sc->NIL && !is_pair(arg))
4094  break;
4095  } else {
4096  if (!tests[j].fct(arg))
4097  break;
4098  }
4099 
4100  if (t[1] != 0) { /* last test is replicated as necessary */
4101  t++;
4102  }
4103  arglist = cdr(arglist);
4104  i++;
4105  } while (i < n);
4106  if (i < n) {
4107  ok = 0;
4108  sprintf(msg, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);
4109  }
4110  }
4111  }
4112  if (!ok) {
4113  if (_Error_1(sc, msg, 0) == sc->NIL) {
4114  return;
4115  }
4116  pcd = dispatch_table + sc->op;
4117  }
4118  }
4119  /*old_op=sc->op;*/
4120  if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
4121  return;
4122  }
4123  if (sc->no_memory) {
4124  fprintf(stderr, "No memory!\n");
4125  return;
4126  }
4127  count++;
4128  }
4129 }
4130 
4131 /* ========== Initialization of internal keywords ========== */
4132 
4133 static void
4134 assign_syntax(scheme* sc, char* name) {
4135  pointer x;
4136 
4137  x = oblist_add_by_name(sc, name);
4138  typeflag(x) |= T_SYNTAX;
4139 }
4140 
4141 static void
4142 assign_proc(scheme* sc, enum scheme_opcodes op, char* name) {
4143  pointer x, y;
4144 
4145  x = mk_symbol(sc, name);
4146  y = mk_proc(sc, op);
4147  new_slot_in_env(sc, x, y);
4148 }
4149 
4150 static pointer
4151 mk_proc(scheme* sc, enum scheme_opcodes op) {
4152  pointer y;
4153 
4154  y = get_cell(sc, sc->NIL, sc->NIL);
4155  typeflag(y) = (T_PROC | T_ATOM);
4156  ivalue_unchecked(y) = (long)op;
4157  set_integer(y);
4158  return y;
4159 }
4160 
4161 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
4162 static int
4163 syntaxnum(pointer p) {
4164  const char* s = strvalue(car(p));
4165  switch (strlength(car(p))) {
4166  case 2:
4167  if (s[0] == 'i')
4168  return OP_IF0; /* if */
4169  else
4170  return OP_OR0; /* or */
4171  case 3:
4172  if (s[0] == 'a')
4173  return OP_AND0; /* and */
4174  else
4175  return OP_LET0; /* let */
4176  case 4:
4177  switch (s[3]) {
4178  case 'e': return OP_CASE0; /* case */
4179  case 'd': return OP_COND0; /* cond */
4180  case '*': return OP_LET0AST; /* let* */
4181  default: return OP_SET0; /* set! */
4182  }
4183  case 5:
4184  switch (s[2]) {
4185  case 'g': return OP_BEGIN; /* begin */
4186  case 'l': return OP_DELAY; /* delay */
4187  case 'c': return OP_MACRO0; /* macro */
4188  default: return OP_QUOTE; /* quote */
4189  }
4190  case 6:
4191  switch (s[2]) {
4192  case 'm': return OP_LAMBDA; /* lambda */
4193  case 'f': return OP_DEF0; /* define */
4194  default: return OP_LET0REC; /* letrec */
4195  }
4196  default: return OP_C0STREAM; /* cons-stream */
4197  }
4198 }
4199 
4200 /* initialization of TinyScheme */
4201 #if USE_INTERFACE
4202 INTERFACE static pointer
4203 s_cons(scheme* sc, pointer a, pointer b) {
4204  return cons(sc, a, b);
4205 }
4206 
4207 INTERFACE static pointer
4208 s_immutable_cons(scheme* sc, pointer a, pointer b) {
4209  return immutable_cons(sc, a, b);
4210 }
4211 
4212 static struct scheme_interface vtbl = { scheme_define,
4213  s_cons,
4214  s_immutable_cons,
4215  mk_integer,
4216  mk_real,
4217  mk_symbol,
4218  gensym,
4219  mk_string,
4220  mk_counted_string,
4221  mk_character,
4222  mk_vector,
4223  mk_foreign_func,
4224  putstr,
4225  putcharacter,
4226 
4227  is_string,
4228  string_value,
4229  is_number,
4230  nvalue,
4231  ivalue,
4232  rvalue,
4233  is_integer,
4234  is_real,
4235  is_character,
4236  charvalue,
4237  is_vector,
4238  ivalue,
4239  fill_vector,
4240  vector_elem,
4241  set_vector_elem,
4242  is_port,
4243  is_pair,
4244  pair_car,
4245  pair_cdr,
4246  set_car,
4247  set_cdr,
4248 
4249  is_symbol,
4250  symname,
4251 
4252  is_syntax,
4253  is_proc,
4254  is_foreign,
4255  syntaxname,
4256  is_closure,
4257  is_macro,
4258  closure_code,
4259  closure_env,
4260 
4261  is_continuation,
4262  is_promise,
4263  is_environment,
4264  is_immutable,
4265  setimmutable,
4266 
4267  scheme_load_file,
4268  scheme_load_string };
4269 #endif
4270 
4271 scheme*
4272 scheme_init_new() {
4273  scheme* sc = (scheme*)malloc(sizeof(scheme));
4274  if (!scheme_init(sc)) {
4275  free(sc);
4276  return 0;
4277  } else {
4278  return sc;
4279  }
4280 }
4281 
4282 scheme*
4283 scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
4284  scheme* sc = (scheme*)malloc(sizeof(scheme));
4285  if (!scheme_init_custom_alloc(sc, malloc, free)) {
4286  free(sc);
4287  return 0;
4288  } else {
4289  return sc;
4290  }
4291 }
4292 
4293 int
4294 scheme_init(scheme* sc) {
4295  return scheme_init_custom_alloc(sc, malloc, free);
4296 }
4297 
4298 int
4299 scheme_init_custom_alloc(scheme* sc, func_alloc malloc, func_dealloc free) {
4300  int i, n = sizeof(dispatch_table) / sizeof(dispatch_table[0]);
4301  pointer x;
4302 
4303  num_zero.is_fixnum = 1;
4304  num_zero.value.ivalue = 0;
4305  num_one.is_fixnum = 1;
4306  num_one.value.ivalue = 1;
4307 
4308 #if USE_INTERFACE
4309  sc->vptr = &vtbl;
4310 #endif
4311  sc->gensym_cnt = 0;
4312  sc->malloc = malloc;
4313  sc->free = free;
4314  sc->last_cell_seg = -1;
4315  sc->sink = &sc->_sink;
4316  sc->NIL = &sc->_NIL;
4317  sc->T = &sc->_HASHT;
4318  sc->F = &sc->_HASHF;
4319  sc->EOF_OBJ = &sc->_EOF_OBJ;
4320  sc->free_cell = &sc->_NIL;
4321  sc->fcells = 0;
4322  sc->no_memory = 0;
4323  sc->inport = sc->NIL;
4324  sc->outport = sc->NIL;
4325  sc->save_inport = sc->NIL;
4326  sc->loadport = sc->NIL;
4327  sc->nesting = 0;
4328  sc->interactive_repl = 0;
4329 
4330  if (alloc_cellseg(sc, FIRST_CELLSEGS) != FIRST_CELLSEGS) {
4331  sc->no_memory = 1;
4332  return 0;
4333  }
4334  sc->gc_verbose = 0;
4335  dump_stack_initialize(sc);
4336  sc->code = sc->NIL;
4337  sc->tracing = 0;
4338 
4339  /* init sc->NIL */
4340  typeflag(sc->NIL) = (T_ATOM | MARK);
4341  car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
4342  /* init T */
4343  typeflag(sc->T) = (T_ATOM | MARK);
4344  car(sc->T) = cdr(sc->T) = sc->T;
4345  /* init F */
4346  typeflag(sc->F) = (T_ATOM | MARK);
4347  car(sc->F) = cdr(sc->F) = sc->F;
4348  sc->oblist = oblist_initial_value(sc);
4349  /* init global_env */
4350  new_frame_in_env(sc, sc->NIL);
4351  sc->global_env = sc->envir;
4352  /* init else */
4353  x = mk_symbol(sc, "else");
4354  new_slot_in_env(sc, x, sc->T);
4355 
4356  assign_syntax(sc, "lambda");
4357  assign_syntax(sc, "quote");
4358  assign_syntax(sc, "define");
4359  assign_syntax(sc, "if");
4360  assign_syntax(sc, "begin");
4361  assign_syntax(sc, "set!");
4362  assign_syntax(sc, "let");
4363  assign_syntax(sc, "let*");
4364  assign_syntax(sc, "letrec");
4365  assign_syntax(sc, "cond");
4366  assign_syntax(sc, "delay");
4367  assign_syntax(sc, "and");
4368  assign_syntax(sc, "or");
4369  assign_syntax(sc, "cons-stream");
4370  assign_syntax(sc, "macro");
4371  assign_syntax(sc, "case");
4372 
4373  for (i = 0; i < n; i++) {
4374  if (dispatch_table[i].name != 0) {
4375  assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
4376  }
4377  }
4378 
4379  /* initialization of global pointers to special symbols */
4380  sc->LAMBDA = mk_symbol(sc, "lambda");
4381  sc->QUOTE = mk_symbol(sc, "quote");
4382  sc->QQUOTE = mk_symbol(sc, "quasiquote");
4383  sc->UNQUOTE = mk_symbol(sc, "unquote");
4384  sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
4385  sc->FEED_TO = mk_symbol(sc, "=>");
4386  sc->COLON_HOOK = mk_symbol(sc, "*colon-hook*");
4387  sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
4388  sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
4389 
4390  return !sc->no_memory;
4391 }
4392 
4393 void
4394 scheme_set_input_port_file(scheme* sc, FILE* fin) {
4395  sc->inport = port_from_file(sc, fin, port_input);
4396 }
4397 
4398 void
4399 scheme_set_input_port_string(scheme* sc, char* start, char* past_the_end) {
4400  sc->inport = port_from_string(sc, start, past_the_end, port_input);
4401 }
4402 
4403 void
4404 scheme_set_output_port_file(scheme* sc, FILE* fout) {
4405  sc->outport = port_from_file(sc, fout, port_output);
4406 }
4407 
4408 void
4409 scheme_set_output_port_string(scheme* sc, char* start, char* past_the_end) {
4410  sc->outport = port_from_string(sc, start, past_the_end, port_output);
4411 }
4412 
4413 void
4414 scheme_set_external_data(scheme* sc, void* p) {
4415  sc->ext_data = p;
4416 }
4417 
4418 void
4419 scheme_deinit(scheme* sc) {
4420  int i;
4421 
4422  sc->oblist = sc->NIL;
4423  sc->global_env = sc->NIL;
4424  dump_stack_free(sc);
4425  sc->envir = sc->NIL;
4426  sc->code = sc->NIL;
4427  sc->args = sc->NIL;
4428  sc->value = sc->NIL;
4429  if (is_port(sc->inport)) {
4430  typeflag(sc->inport) = T_ATOM;
4431  }
4432  sc->inport = sc->NIL;
4433  sc->outport = sc->NIL;
4434  if (is_port(sc->save_inport)) {
4435  typeflag(sc->save_inport) = T_ATOM;
4436  }
4437  sc->save_inport = sc->NIL;
4438  if (is_port(sc->loadport)) {
4439  typeflag(sc->loadport) = T_ATOM;
4440  }
4441  sc->loadport = sc->NIL;
4442  sc->gc_verbose = 0;
4443  gc(sc, sc->NIL, sc->NIL);
4444 
4445  for (i = 0; i <= sc->last_cell_seg; i++) {
4446  sc->free(sc->alloc_seg[i]);
4447  }
4448 }
4449 
4450 void
4451 scheme_load_file(scheme* sc, FILE* fin) {
4452  dump_stack_reset(sc);
4453  sc->envir = sc->global_env;
4454  sc->file_i = 0;
4455  sc->load_stack[0].kind = port_input | port_file;
4456  sc->load_stack[0].rep.stdio.file = fin;
4457  sc->loadport = mk_port(sc, sc->load_stack);
4458  sc->retcode = 0;
4459  if (fin == stdin) {
4460  sc->interactive_repl = 1;
4461  }
4462  sc->inport = sc->loadport;
4463  Eval_Cycle(sc, OP_T0LVL);
4464  typeflag(sc->loadport) = T_ATOM;
4465  if (sc->retcode == 0) {
4466  sc->retcode = sc->nesting != 0;
4467  }
4468 }
4469 
4470 void
4471 scheme_load_string(scheme* sc, const char* cmd) {
4472  dump_stack_reset(sc);
4473  sc->envir = sc->global_env;
4474  sc->file_i = 0;
4475  sc->load_stack[0].kind = port_input | port_string;
4476  sc->load_stack[0].rep.string.start = (char*)cmd; /* This func respects const */
4477  sc->load_stack[0].rep.string.past_the_end = (char*)cmd + strlen(cmd);
4478  sc->load_stack[0].rep.string.curr = (char*)cmd;
4479  sc->loadport = mk_port(sc, sc->load_stack);
4480  sc->retcode = 0;
4481  sc->interactive_repl = 0;
4482  sc->inport = sc->loadport;
4483  Eval_Cycle(sc, OP_T0LVL);
4484  typeflag(sc->loadport) = T_ATOM;
4485  if (sc->retcode == 0) {
4486  sc->retcode = sc->nesting != 0;
4487  }
4488 }
4489 
4490 void
4491 scheme_define(scheme* sc, pointer envir, pointer symbol, pointer value) {
4492  pointer x;
4493 
4494  x = find_slot_in_env(sc, envir, symbol, 0);
4495  if (x != sc->NIL) {
4496  set_slot_in_env(sc, x, value);
4497  } else {
4498  new_slot_spec_in_env(sc, envir, symbol, value);
4499  }
4500 }
4501 
4502 #if !STANDALONE
4503 void
4504 scheme_apply0(scheme* sc, const char* procname) {
4505  pointer carx = mk_symbol(sc, procname);
4506  pointer cdrx = sc->NIL;
4507 
4508  dump_stack_reset(sc);
4509  sc->envir = sc->global_env;
4510  sc->code = cons(sc, carx, cdrx);
4511  sc->interactive_repl = 0;
4512  sc->retcode = 0;
4513  Eval_Cycle(sc, OP_EVAL);
4514 }
4515 
4516 void
4517 scheme_call(scheme* sc, pointer func, pointer args) {
4518  dump_stack_reset(sc);
4519  sc->envir = sc->global_env;
4520  sc->args = args;
4521  sc->code = func;
4522  sc->interactive_repl = 0;
4523  sc->retcode = 0;
4524  Eval_Cycle(sc, OP_APPLY);
4525 }
4526 #endif
4527 
4528 /* ========== Main ========== */
4529 
4530 #if STANDALONE
4531 
4532 #ifdef macintosh
4533 int
4534 main() {
4535  extern MacTS_main(int argc, char** argv);
4536  char** argv;
4537  int argc = ccommand(&argv);
4538  MacTS_main(argc, argv);
4539  return 0;
4540 }
4541 int
4542 MacTS_main(int argc, char** argv) {
4543 #else
4544 int
4545 main(int argc, char** argv) {
4546 #endif
4547  scheme sc;
4548  FILE* fin = 0;
4549  char* file_name = InitFile;
4550  int retcode;
4551  int isfile = 1;
4552 
4553  if (argc == 1) {
4554  printf(banner);
4555  }
4556  if (argc == 2 && strcmp(argv[1], "-?") == 0) {
4557  printf(
4558  "Usage: %s [-? | <file1> <file2> ... | -1 <file> <arg1> <arg2> ...]\n\tUse - as filename for stdin.\n",
4559  argv[0]
4560  );
4561  return 1;
4562  }
4563  if (!scheme_init(&sc)) {
4564  fprintf(stderr, "Could not initialize!\n");
4565  return 2;
4566  }
4567  scheme_set_input_port_file(&sc, stdin);
4568  scheme_set_output_port_file(&sc, stdout);
4569 #if USE_DL
4570  scheme_define(&sc, sc.global_env, mk_symbol(&sc, "load-extension"), mk_foreign_func(&sc, scm_load_ext));
4571 #endif
4572  argv++;
4573  if (access(file_name, 0) != 0) {
4574  char* p = getenv("TINYSCHEMEINIT");
4575  if (p != 0) {
4576  file_name = p;
4577  }
4578  }
4579  do {
4580  if (strcmp(file_name, "-") == 0) {
4581  fin = stdin;
4582  } else if (strcmp(file_name, "-1") == 0 || strcmp(file_name, "-c") == 0) {
4583  pointer args = sc.NIL;
4584  isfile = file_name[1] == '1';
4585  file_name = *argv++;
4586  if (strcmp(file_name, "-") == 0) {
4587  fin = stdin;
4588  } else if (isfile) {
4589  fin = fopen(file_name, "r");
4590  }
4591  for (; *argv; argv++) {
4592  pointer value = mk_string(&sc, *argv);
4593  args = cons(&sc, value, args);
4594  }
4595  args = reverse_in_place(&sc, sc.NIL, args);
4596  scheme_define(&sc, sc.global_env, mk_symbol(&sc, "*args*"), args);
4597 
4598  } else {
4599  fin = fopen(file_name, "r");
4600  }
4601  if (isfile && fin == 0) {
4602  fprintf(stderr, "Could not open file %s\n", file_name);
4603  } else {
4604  if (isfile) {
4605  scheme_load_file(&sc, fin);
4606  } else {
4607  scheme_load_string(&sc, file_name);
4608  }
4609  if (!isfile || fin != stdin) {
4610  if (sc.retcode != 0) {
4611  fprintf(stderr, "Errors encountered reading %s\n", file_name);
4612  }
4613  if (isfile) {
4614  fclose(fin);
4615  }
4616  }
4617  }
4618  file_name = *argv++;
4619  } while (file_name != 0);
4620  if (argc == 1) {
4621  scheme_load_file(&sc, stdin);
4622  }
4623  retcode = sc.retcode;
4624  scheme_deinit(&sc);
4625 
4626  return retcode;
4627 }
4628 
4629 #endif
Header info for the dynamic loader functions for TinyScheme.
More support data for the TinyScheme parser.
Private data for the TinyScheme compiler.