gpgscm: Keep a history of calls for error messages.
[gnupg.git] / tests / gpgscm / scheme.c
1 /* T I N Y S C H E M E    1 . 4 1
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
15 #define _SCHEME_SOURCE
16 #include "scheme-private.h"
17 #ifndef WIN32
18 # include <unistd.h>
19 #endif
20 #ifdef WIN32
21 #define snprintf _snprintf
22 #endif
23 #if USE_DL
24 # include "dynload.h"
25 #endif
26 #if USE_MATH
27 # include <math.h>
28 #endif
29
30 #include <assert.h>
31 #include <limits.h>
32 #include <stdint.h>
33 #include <float.h>
34 #include <ctype.h>
35
36 #if USE_STRCASECMP
37 #include <strings.h>
38 # ifndef __APPLE__
39 #  define stricmp strcasecmp
40 # endif
41 #endif
42
43 /* Used for documentation purposes, to signal functions in 'interface' */
44 #define INTERFACE
45
46 #define TOK_EOF     (-1)
47 #define TOK_LPAREN  0
48 #define TOK_RPAREN  1
49 #define TOK_DOT     2
50 #define TOK_ATOM    3
51 #define TOK_QUOTE   4
52 #define TOK_COMMENT 5
53 #define TOK_DQUOTE  6
54 #define TOK_BQUOTE  7
55 #define TOK_COMMA   8
56 #define TOK_ATMARK  9
57 #define TOK_SHARP   10
58 #define TOK_SHARP_CONST 11
59 #define TOK_VEC     12
60
61 #define BACKQUOTE '`'
62 #define DELIMITERS  "()\";\f\t\v\n\r "
63
64 /*
65  *  Basic memory allocation units
66  */
67
68 #define banner "TinyScheme 1.41"
69
70 #include <string.h>
71 #include <stddef.h>
72 #include <stdlib.h>
73
74 #ifdef __APPLE__
75 static int stricmp(const char *s1, const char *s2)
76 {
77   unsigned char c1, c2;
78   do {
79     c1 = tolower(*s1);
80     c2 = tolower(*s2);
81     if (c1 < c2)
82       return -1;
83     else if (c1 > c2)
84       return 1;
85     s1++, s2++;
86   } while (c1 != 0);
87   return 0;
88 }
89 #endif /* __APPLE__ */
90
91 #if USE_STRLWR
92 static const char *strlwr(char *s) {
93   const char *p=s;
94   while(*s) {
95     *s=tolower(*s);
96     s++;
97   }
98   return p;
99 }
100 #endif
101
102 #ifndef prompt
103 # define prompt "ts> "
104 #endif
105
106 #ifndef InitFile
107 # define InitFile "init.scm"
108 #endif
109
110 #ifndef FIRST_CELLSEGS
111 # define FIRST_CELLSEGS 3
112 #endif
113
114 enum scheme_types {
115   T_STRING=1,
116   T_NUMBER=2,
117   T_SYMBOL=3,
118   T_PROC=4,
119   T_PAIR=5,
120   T_CLOSURE=6,
121   T_CONTINUATION=7,
122   T_FOREIGN=8,
123   T_CHARACTER=9,
124   T_PORT=10,
125   T_VECTOR=11,
126   T_MACRO=12,
127   T_PROMISE=13,
128   T_ENVIRONMENT=14,
129   T_FOREIGN_OBJECT=15,
130   T_BOOLEAN=16,
131   T_NIL=17,
132   T_EOF_OBJ=18,
133   T_SINK=19,
134   T_LAST_SYSTEM_TYPE=19
135 };
136
137 static const char *
138 type_to_string (enum scheme_types typ)
139 {
140      switch (typ)
141      {
142      case T_STRING: return "string";
143      case T_NUMBER: return "number";
144      case T_SYMBOL: return "symbol";
145      case T_PROC: return "proc";
146      case T_PAIR: return "pair";
147      case T_CLOSURE: return "closure";
148      case T_CONTINUATION: return "continuation";
149      case T_FOREIGN: return "foreign";
150      case T_CHARACTER: return "character";
151      case T_PORT: return "port";
152      case T_VECTOR: return "vector";
153      case T_MACRO: return "macro";
154      case T_PROMISE: return "promise";
155      case T_ENVIRONMENT: return "environment";
156      case T_FOREIGN_OBJECT: return "foreign object";
157      case T_BOOLEAN: return "boolean";
158      case T_NIL: return "nil";
159      case T_EOF_OBJ: return "eof object";
160      case T_SINK: return "sink";
161      }
162      assert (! "not reached");
163 }
164
165 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
166 #define ADJ 32
167 #define TYPE_BITS 5
168 #define T_MASKTYPE      31    /* 0000000000011111 */
169 #define T_TAGGED      1024    /* 0000010000000000 */
170 #define T_FINALIZE    2048    /* 0000100000000000 */
171 #define T_SYNTAX      4096    /* 0001000000000000 */
172 #define T_IMMUTABLE   8192    /* 0010000000000000 */
173 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
174 #define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
175 #define MARK         32768    /* 1000000000000000 */
176 #define UNMARK       32767    /* 0111111111111111 */
177
178
179 static num num_add(num a, num b);
180 static num num_mul(num a, num b);
181 static num num_div(num a, num b);
182 static num num_intdiv(num a, num b);
183 static num num_sub(num a, num b);
184 static num num_rem(num a, num b);
185 static num num_mod(num a, num b);
186 static int num_eq(num a, num b);
187 static int num_gt(num a, num b);
188 static int num_ge(num a, num b);
189 static int num_lt(num a, num b);
190 static int num_le(num a, num b);
191
192 #if USE_MATH
193 static double round_per_R5RS(double x);
194 #endif
195 static int is_zero_double(double x);
196 static INLINE int num_is_integer(pointer p) {
197   return ((p)->_object._number.is_fixnum);
198 }
199
200 static num num_zero;
201 static num num_one;
202
203 /* macros for cell operations */
204 #define typeflag(p)      ((p)->_flag)
205 #define type(p)          (typeflag(p)&T_MASKTYPE)
206
207 INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
208 #define strvalue(p)      ((p)->_object._string._svalue)
209 #define strlength(p)        ((p)->_object._string._length)
210
211 INTERFACE static int is_list(scheme *sc, pointer p);
212 INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
213 INTERFACE static void fill_vector(pointer vec, pointer obj);
214 INTERFACE static pointer vector_elem(pointer vec, int ielem);
215 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
216 INTERFACE INLINE int is_number(pointer p)    { return (type(p)==T_NUMBER); }
217 INTERFACE INLINE int is_integer(pointer p) {
218   if (!is_number(p))
219       return 0;
220   if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
221       return 1;
222   return 0;
223 }
224
225 INTERFACE INLINE int is_real(pointer p) {
226   return is_number(p) && (!(p)->_object._number.is_fixnum);
227 }
228
229 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
230 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
231 INLINE num nvalue(pointer p)       { return ((p)->_object._number); }
232 INTERFACE long ivalue(pointer p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
233 INTERFACE double rvalue(pointer p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
234 #define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
235 #define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
236 #define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
237 #define set_num_real(p)      (p)->_object._number.is_fixnum=0;
238 INTERFACE  long charvalue(pointer p)  { return ivalue_unchecked(p); }
239
240 INTERFACE INLINE int is_port(pointer p)     { return (type(p)==T_PORT); }
241 INTERFACE INLINE int is_inport(pointer p)  { return is_port(p) && p->_object._port->kind & port_input; }
242 INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
243
244 INTERFACE INLINE int is_pair(pointer p)     { return (type(p)==T_PAIR); }
245 #define car(p)           ((p)->_object._cons._car)
246 #define cdr(p)           ((p)->_object._cons._cdr)
247 INTERFACE pointer pair_car(pointer p)   { return car(p); }
248 INTERFACE pointer pair_cdr(pointer p)   { return cdr(p); }
249 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
250 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
251
252 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
253 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
254 #if USE_PLIST
255 SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (is_symbol(p)); }
256 #define symprop(p)       cdr(p)
257 #endif
258
259 INTERFACE INLINE int is_syntax(pointer p)   { return (typeflag(p)&T_SYNTAX); }
260 INTERFACE INLINE int is_proc(pointer p)     { return (type(p)==T_PROC); }
261 INTERFACE INLINE int is_foreign(pointer p)  { return (type(p)==T_FOREIGN); }
262 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
263 #define procnum(p)       ivalue(p)
264 static const char *procname(pointer x);
265
266 INTERFACE INLINE int is_closure(pointer p)  { return (type(p)==T_CLOSURE); }
267 INTERFACE INLINE int is_macro(pointer p)    { return (type(p)==T_MACRO); }
268 INTERFACE INLINE pointer closure_code(pointer p)   { return car(p); }
269 INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
270
271 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
272 #define cont_dump(p)     cdr(p)
273
274 INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
275 INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
276   return p->_object._foreign_object._vtable;
277 }
278 INTERFACE void *get_foreign_object_data(pointer p) {
279   return p->_object._foreign_object._data;
280 }
281
282 /* To do: promise should be forced ONCE only */
283 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
284
285 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
286 #define setenvironment(p)    typeflag(p) = T_ENVIRONMENT
287
288 #define is_atom(p)       (typeflag(p)&T_ATOM)
289 #define setatom(p)       typeflag(p) |= T_ATOM
290 #define clratom(p)       typeflag(p) &= CLRATOM
291
292 #define is_mark(p)       (typeflag(p)&MARK)
293 #define setmark(p)       typeflag(p) |= MARK
294 #define clrmark(p)       typeflag(p) &= UNMARK
295
296 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
297 /*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
298 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
299
300 #define caar(p)          car(car(p))
301 #define cadr(p)          car(cdr(p))
302 #define cdar(p)          cdr(car(p))
303 #define cddr(p)          cdr(cdr(p))
304 #define cadar(p)         car(cdr(car(p)))
305 #define caddr(p)         car(cdr(cdr(p)))
306 #define cdaar(p)         cdr(car(car(p)))
307 #define cadaar(p)        car(cdr(car(car(p))))
308 #define cadddr(p)        car(cdr(cdr(cdr(p))))
309 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
310
311 #if USE_HISTORY
312 static pointer history_flatten(scheme *sc);
313 static void history_mark(scheme *sc);
314 #else
315 # define history_mark(SC)       (void) 0
316 # define history_flatten(SC)    (SC)->NIL
317 #endif
318
319 #if USE_CHAR_CLASSIFIERS
320 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
321 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
322 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
323 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
324 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
325 #endif
326
327 #if USE_ASCII_NAMES
328 static const char *charnames[32]={
329  "nul",
330  "soh",
331  "stx",
332  "etx",
333  "eot",
334  "enq",
335  "ack",
336  "bel",
337  "bs",
338  "ht",
339  "lf",
340  "vt",
341  "ff",
342  "cr",
343  "so",
344  "si",
345  "dle",
346  "dc1",
347  "dc2",
348  "dc3",
349  "dc4",
350  "nak",
351  "syn",
352  "etb",
353  "can",
354  "em",
355  "sub",
356  "esc",
357  "fs",
358  "gs",
359  "rs",
360  "us"
361 };
362
363 static int is_ascii_name(const char *name, int *pc) {
364   int i;
365   for(i=0; i<32; i++) {
366      if(stricmp(name,charnames[i])==0) {
367           *pc=i;
368           return 1;
369      }
370   }
371   if(stricmp(name,"del")==0) {
372      *pc=127;
373      return 1;
374   }
375   return 0;
376 }
377
378 #endif
379
380 static int file_push(scheme *sc, const char *fname);
381 static void file_pop(scheme *sc);
382 static int file_interactive(scheme *sc);
383 static INLINE int is_one_of(char *s, int c);
384 static int alloc_cellseg(scheme *sc, int n);
385 static long binary_decode(const char *s);
386 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
387 static pointer _get_cell(scheme *sc, pointer a, pointer b);
388 static pointer reserve_cells(scheme *sc, int n);
389 static pointer get_consecutive_cells(scheme *sc, int n);
390 static pointer find_consecutive_cells(scheme *sc, int n);
391 static void finalize_cell(scheme *sc, pointer a);
392 static int count_consecutive_cells(pointer x, int needed);
393 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
394 static pointer mk_number(scheme *sc, num n);
395 static char *store_string(scheme *sc, int len, const char *str, char fill);
396 static pointer mk_vector(scheme *sc, int len);
397 static pointer mk_atom(scheme *sc, char *q);
398 static pointer mk_sharp_const(scheme *sc, char *name);
399 static pointer mk_port(scheme *sc, port *p);
400 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
401 static pointer port_from_file(scheme *sc, FILE *, int prop);
402 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
403 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
404 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
405 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
406 static void port_close(scheme *sc, pointer p, int flag);
407 static void mark(pointer a);
408 static void gc(scheme *sc, pointer a, pointer b);
409 static int basic_inchar(port *pt);
410 static int inchar(scheme *sc);
411 static void backchar(scheme *sc, int c);
412 static char   *readstr_upto(scheme *sc, char *delim);
413 static pointer readstrexp(scheme *sc);
414 static INLINE int skipspace(scheme *sc);
415 static int token(scheme *sc);
416 static void printslashstring(scheme *sc, char *s, int len);
417 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
418 static void printatom(scheme *sc, pointer l, int f);
419 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
420 static pointer mk_closure(scheme *sc, pointer c, pointer e);
421 static pointer mk_continuation(scheme *sc, pointer d);
422 static pointer reverse(scheme *sc, pointer term, pointer list);
423 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
424 static pointer revappend(scheme *sc, pointer a, pointer b);
425 static void dump_stack_mark(scheme *);
426 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
427 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
428 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
429 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
430 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
431 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
432 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
433 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
434 static void assign_syntax(scheme *sc, char *name);
435 static int syntaxnum(pointer p);
436 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
437
438 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
439 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
440
441 static num num_add(num a, num b) {
442  num ret;
443  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
444  if(ret.is_fixnum) {
445      ret.value.ivalue= a.value.ivalue+b.value.ivalue;
446  } else {
447      ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
448  }
449  return ret;
450 }
451
452 static num num_mul(num a, num b) {
453  num ret;
454  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
455  if(ret.is_fixnum) {
456      ret.value.ivalue= a.value.ivalue*b.value.ivalue;
457  } else {
458      ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
459  }
460  return ret;
461 }
462
463 static num num_div(num a, num b) {
464  num ret;
465  ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
466  if(ret.is_fixnum) {
467      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
468  } else {
469      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
470  }
471  return ret;
472 }
473
474 static num num_intdiv(num a, num b) {
475  num ret;
476  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
477  if(ret.is_fixnum) {
478      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
479  } else {
480      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
481  }
482  return ret;
483 }
484
485 static num num_sub(num a, num b) {
486  num ret;
487  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
488  if(ret.is_fixnum) {
489      ret.value.ivalue= a.value.ivalue-b.value.ivalue;
490  } else {
491      ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
492  }
493  return ret;
494 }
495
496 static num num_rem(num a, num b) {
497  num ret;
498  long e1, e2, res;
499  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
500  e1=num_ivalue(a);
501  e2=num_ivalue(b);
502  res=e1%e2;
503  /* remainder should have same sign as second operand */
504  if (res > 0) {
505      if (e1 < 0) {
506         res -= labs(e2);
507      }
508  } else if (res < 0) {
509      if (e1 > 0) {
510          res += labs(e2);
511      }
512  }
513  ret.value.ivalue=res;
514  return ret;
515 }
516
517 static num num_mod(num a, num b) {
518  num ret;
519  long e1, e2, res;
520  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
521  e1=num_ivalue(a);
522  e2=num_ivalue(b);
523  res=e1%e2;
524  /* modulo should have same sign as second operand */
525  if (res * e2 < 0) {
526     res += e2;
527  }
528  ret.value.ivalue=res;
529  return ret;
530 }
531
532 static int num_eq(num a, num b) {
533  int ret;
534  int is_fixnum=a.is_fixnum && b.is_fixnum;
535  if(is_fixnum) {
536      ret= a.value.ivalue==b.value.ivalue;
537  } else {
538      ret=num_rvalue(a)==num_rvalue(b);
539  }
540  return ret;
541 }
542
543
544 static int num_gt(num a, num b) {
545  int ret;
546  int is_fixnum=a.is_fixnum && b.is_fixnum;
547  if(is_fixnum) {
548      ret= a.value.ivalue>b.value.ivalue;
549  } else {
550      ret=num_rvalue(a)>num_rvalue(b);
551  }
552  return ret;
553 }
554
555 static int num_ge(num a, num b) {
556  return !num_lt(a,b);
557 }
558
559 static int num_lt(num a, num b) {
560  int ret;
561  int is_fixnum=a.is_fixnum && b.is_fixnum;
562  if(is_fixnum) {
563      ret= a.value.ivalue<b.value.ivalue;
564  } else {
565      ret=num_rvalue(a)<num_rvalue(b);
566  }
567  return ret;
568 }
569
570 static int num_le(num a, num b) {
571  return !num_gt(a,b);
572 }
573
574 #if USE_MATH
575 /* Round to nearest. Round to even if midway */
576 static double round_per_R5RS(double x) {
577  double fl=floor(x);
578  double ce=ceil(x);
579  double dfl=x-fl;
580  double dce=ce-x;
581  if(dfl>dce) {
582      return ce;
583  } else if(dfl<dce) {
584      return fl;
585  } else {
586      if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
587           return fl;
588      } else {
589           return ce;
590      }
591  }
592 }
593 #endif
594
595 static int is_zero_double(double x) {
596  return x<DBL_MIN && x>-DBL_MIN;
597 }
598
599 static long binary_decode(const char *s) {
600  long x=0;
601
602  while(*s!=0 && (*s=='1' || *s=='0')) {
603      x<<=1;
604      x+=*s-'0';
605      s++;
606  }
607
608  return x;
609 }
610
611 \f
612
613 /* Tags are like property lists, but can be attached to arbitrary
614  * values.  */
615
616 #if USE_TAGS
617
618 static pointer
619 mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
620 {
621   pointer r, t;
622
623   assert(! is_vector(v));
624
625   r = get_consecutive_cells(sc, 2);
626   if (r == sc->sink)
627     return sc->sink;
628
629   memcpy(r, v, sizeof *v);
630   typeflag(r) |= T_TAGGED;
631
632   t = r + 1;
633   typeflag(t) = T_PAIR;
634   car(t) = tag_car;
635   cdr(t) = tag_cdr;
636
637   return r;
638 }
639
640 static INLINE int
641 has_tag(pointer v)
642 {
643   return !! (typeflag(v) & T_TAGGED);
644 }
645
646 static INLINE pointer
647 get_tag(scheme *sc, pointer v)
648 {
649   if (has_tag(v))
650     return v + 1;
651   return sc->NIL;
652 }
653
654 #else
655
656 #define mk_tagged_value(SC, X, A, B)    (X)
657 #define has_tag(V)                      0
658 #define get_tag(SC, V)                  (SC)->NIL
659
660 #endif
661
662 \f
663
664 /* Allocate a new cell segment but do not make it available yet.  */
665 static int
666 _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
667 {
668   int adj = ADJ;
669   void *cp;
670
671   if (adj < sizeof(struct cell))
672     adj = sizeof(struct cell);
673
674   cp = sc->malloc(len * sizeof(struct cell) + adj);
675   if (cp == NULL)
676     return 1;
677
678   *alloc = cp;
679
680   /* adjust in TYPE_BITS-bit boundary */
681   if (((uintptr_t) cp) % adj != 0)
682     cp = (void *) (adj * ((uintptr_t) cp / adj + 1));
683
684   *cells = cp;
685   return 0;
686 }
687
688 /* allocate new cell segment */
689 static int alloc_cellseg(scheme *sc, int n) {
690      pointer newp;
691      pointer last;
692      pointer p;
693      long i;
694      int k;
695
696      for (k = 0; k < n; k++) {
697          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
698               return k;
699          i = ++sc->last_cell_seg;
700          if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) {
701               sc->last_cell_seg--;
702               return k;
703          }
704          /* insert new segment in address order */
705          sc->cell_seg[i] = newp;
706          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
707              p = sc->cell_seg[i];
708              sc->cell_seg[i] = sc->cell_seg[i - 1];
709              sc->cell_seg[--i] = p;
710          }
711          sc->fcells += CELL_SEGSIZE;
712          last = newp + CELL_SEGSIZE - 1;
713          for (p = newp; p <= last; p++) {
714               typeflag(p) = 0;
715               cdr(p) = p + 1;
716               car(p) = sc->NIL;
717          }
718          /* insert new cells in address order on free list */
719          if (sc->free_cell == sc->NIL || p < sc->free_cell) {
720               cdr(last) = sc->free_cell;
721               sc->free_cell = newp;
722          } else {
723                p = sc->free_cell;
724                while (cdr(p) != sc->NIL && newp > cdr(p))
725                     p = cdr(p);
726                cdr(last) = cdr(p);
727                cdr(p) = newp;
728          }
729      }
730      return n;
731 }
732
733 \f
734
735 /* Controlling the garbage collector.
736  *
737  * Every time a cell is allocated, the interpreter may run out of free
738  * cells and do a garbage collection.  This is problematic because it
739  * might garbage collect objects that have been allocated, but are not
740  * yet made available to the interpreter.
741  *
742  * Previously, we would plug such newly allocated cells into the list
743  * of newly allocated objects rooted at car(sc->sink), but that
744  * requires allocating yet another cell increasing pressure on the
745  * memory management system.
746  *
747  * A faster alternative is to preallocate the cells needed for an
748  * operation and make sure the garbage collection is not run until all
749  * allocated objects are plugged in.  This can be done with gc_disable
750  * and gc_enable.
751  */
752
753 /* The garbage collector is enabled if the inhibit counter is
754  * zero.  */
755 #define GC_ENABLED      0
756
757 /* For now we provide a way to disable this optimization for
758  * benchmarking and because it produces slightly smaller code.  */
759 #ifndef USE_GC_LOCKING
760 # define USE_GC_LOCKING 1
761 #endif
762
763 /* To facilitate nested calls to gc_disable, functions that allocate
764  * more than one cell may define a macro, e.g. foo_allocates.  This
765  * macro can be used to compute the amount of preallocation at the
766  * call site with the help of this macro.  */
767 #define gc_reservations(fn) fn ## _allocates
768
769 #if USE_GC_LOCKING
770
771 /* Report a shortage in reserved cells, and terminate the program.  */
772 static void
773 gc_reservation_failure(struct scheme *sc)
774 {
775 #ifdef NDEBUG
776   fprintf(stderr,
777           "insufficient reservation\n")
778 #else
779   fprintf(stderr,
780           "insufficient reservation in line %d\n",
781           sc->reserved_lineno);
782 #endif
783   abort();
784 }
785
786 /* Disable the garbage collection and reserve the given number of
787  * cells.  gc_disable may be nested, but the enclosing reservation
788  * must include the reservations of all nested calls.  Note: You must
789  * re-enable the gc before calling Error_X.  */
790 static void
791 _gc_disable(struct scheme *sc, size_t reserve, int lineno)
792 {
793   if (sc->inhibit_gc == 0) {
794     reserve_cells(sc, (reserve));
795     sc->reserved_cells = (reserve);
796 #ifndef NDEBUG
797     (void) lineno;
798 #else
799     sc->reserved_lineno = lineno;
800 #endif
801   } else if (sc->reserved_cells < (reserve))
802     gc_reservation_failure (sc);
803   sc->inhibit_gc += 1;
804 }
805 #define gc_disable(sc, reserve)                 \
806      _gc_disable (sc, reserve, __LINE__)
807
808 /* Enable the garbage collector.  */
809 #define gc_enable(sc)                           \
810      do {                                       \
811           assert(sc->inhibit_gc);               \
812           sc->inhibit_gc -= 1;                  \
813      } while (0)
814
815 /* Test whether the garbage collector is enabled.  */
816 #define gc_enabled(sc)                          \
817      (sc->inhibit_gc == GC_ENABLED)
818
819 /* Consume a reserved cell.  */
820 #define gc_consume(sc)                                                  \
821      do {                                                               \
822           assert(! gc_enabled (sc));                                    \
823           if (sc->reserved_cells == 0)                                  \
824                gc_reservation_failure (sc);                             \
825           sc->reserved_cells -= 1;                                      \
826      } while (0)
827
828 #else /* USE_GC_LOCKING */
829
830 #define gc_disable(sc, reserve) (void) 0
831 #define gc_enable(sc)   (void) 0
832 #define gc_enabled(sc)  1
833 #define gc_consume(sc)  (void) 0
834
835 #endif /* USE_GC_LOCKING */
836
837 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
838   if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
839     pointer x = sc->free_cell;
840     if (! gc_enabled (sc))
841          gc_consume (sc);
842     sc->free_cell = cdr(x);
843     --sc->fcells;
844     return (x);
845   }
846   assert (gc_enabled (sc));
847   return _get_cell (sc, a, b);
848 }
849
850
851 /* get new cell.  parameter a, b is marked by gc. */
852 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
853   pointer x;
854
855   if(sc->no_memory) {
856     return sc->sink;
857   }
858
859   assert (gc_enabled (sc));
860   if (sc->free_cell == sc->NIL) {
861     const int min_to_be_recovered = sc->last_cell_seg*8;
862     gc(sc,a, b);
863     if (sc->fcells < min_to_be_recovered
864         || sc->free_cell == sc->NIL) {
865       /* if only a few recovered, get more to avoid fruitless gc's */
866       if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
867         sc->no_memory=1;
868         return sc->sink;
869       }
870     }
871   }
872   x = sc->free_cell;
873   sc->free_cell = cdr(x);
874   --sc->fcells;
875   return (x);
876 }
877
878 /* make sure that there is a given number of cells free */
879 static pointer reserve_cells(scheme *sc, int n) {
880     if(sc->no_memory) {
881         return sc->NIL;
882     }
883
884     /* Are there enough cells available? */
885     if (sc->fcells < n) {
886         /* If not, try gc'ing some */
887         gc(sc, sc->NIL, sc->NIL);
888         if (sc->fcells < n) {
889             /* If there still aren't, try getting more heap */
890             if (!alloc_cellseg(sc,1)) {
891                 sc->no_memory=1;
892                 return sc->NIL;
893             }
894         }
895         if (sc->fcells < n) {
896             /* If all fail, report failure */
897             sc->no_memory=1;
898             return sc->NIL;
899         }
900     }
901     return (sc->T);
902 }
903
904 static pointer get_consecutive_cells(scheme *sc, int n) {
905   pointer x;
906
907   if(sc->no_memory) { return sc->sink; }
908
909   /* Are there any cells available? */
910   x=find_consecutive_cells(sc,n);
911   if (x != sc->NIL) { return x; }
912
913   /* If not, try gc'ing some */
914   gc(sc, sc->NIL, sc->NIL);
915   x=find_consecutive_cells(sc,n);
916   if (x != sc->NIL) { return x; }
917
918   /* If there still aren't, try getting more heap */
919   if (!alloc_cellseg(sc,1))
920     {
921       sc->no_memory=1;
922       return sc->sink;
923     }
924
925   x=find_consecutive_cells(sc,n);
926   if (x != sc->NIL) { return x; }
927
928   /* If all fail, report failure */
929   sc->no_memory=1;
930   return sc->sink;
931 }
932
933 static int count_consecutive_cells(pointer x, int needed) {
934  int n=1;
935  while(cdr(x)==x+1) {
936      x=cdr(x);
937      n++;
938      if(n>needed) return n;
939  }
940  return n;
941 }
942
943 static pointer find_consecutive_cells(scheme *sc, int n) {
944   pointer *pp;
945   int cnt;
946
947   pp=&sc->free_cell;
948   while(*pp!=sc->NIL) {
949     cnt=count_consecutive_cells(*pp,n);
950     if(cnt>=n) {
951       pointer x=*pp;
952       *pp=cdr(*pp+n-1);
953       sc->fcells -= n;
954       return x;
955     }
956     pp=&cdr(*pp+cnt-1);
957   }
958   return sc->NIL;
959 }
960
961 /* Free a cell.  This is dangerous.  Only free cells that are not
962  * referenced.  */
963 static INLINE void
964 free_cell(scheme *sc, pointer a)
965 {
966   cdr(a) = sc->free_cell;
967   sc->free_cell = a;
968   sc->fcells += 1;
969 }
970
971 /* Free a cell and retrieve its content.  This is dangerous.  Only
972  * free cells that are not referenced.  */
973 static INLINE void
974 free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
975 {
976   *r_car = car(a);
977   *r_cdr = cdr(a);
978   free_cell(sc, a);
979 }
980
981 /* To retain recent allocs before interpreter knows about them -
982    Tehom */
983
984 static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
985 {
986   pointer holder = get_cell_x(sc, recent, extra);
987   typeflag(holder) = T_PAIR | T_IMMUTABLE;
988   car(holder) = recent;
989   cdr(holder) = car(sc->sink);
990   car(sc->sink) = holder;
991 }
992
993 static INLINE void ok_to_freely_gc(scheme *sc)
994 {
995   pointer a = car(sc->sink), next;
996   car(sc->sink) = sc->NIL;
997   while (a != sc->NIL)
998     {
999       next = cdr(a);
1000       free_cell(sc, a);
1001       a = next;
1002     }
1003 }
1004
1005 static pointer get_cell(scheme *sc, pointer a, pointer b)
1006 {
1007   pointer cell   = get_cell_x(sc, a, b);
1008   /* For right now, include "a" and "b" in "cell" so that gc doesn't
1009      think they are garbage. */
1010   /* Tentatively record it as a pair so gc understands it. */
1011   typeflag(cell) = T_PAIR;
1012   car(cell) = a;
1013   cdr(cell) = b;
1014   if (gc_enabled (sc))
1015     push_recent_alloc(sc, cell, sc->NIL);
1016   return cell;
1017 }
1018
1019 static pointer get_vector_object(scheme *sc, int len, pointer init)
1020 {
1021   pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
1022   if(sc->no_memory) { return sc->sink; }
1023   /* Record it as a vector so that gc understands it. */
1024   typeflag(cells) = (T_VECTOR | T_ATOM);
1025   ivalue_unchecked(cells)=len;
1026   set_num_integer(cells);
1027   fill_vector(cells,init);
1028   if (gc_enabled (sc))
1029     push_recent_alloc(sc, cells, sc->NIL);
1030   return cells;
1031 }
1032
1033 #if defined TSGRIND
1034 static void check_cell_alloced(pointer p, int expect_alloced)
1035 {
1036   /* Can't use putstr(sc,str) because callers have no access to
1037      sc.  */
1038   if(typeflag(p) & !expect_alloced)
1039     {
1040       fprintf(stderr,"Cell is already allocated!\n");
1041     }
1042   if(!(typeflag(p)) & expect_alloced)
1043     {
1044       fprintf(stderr,"Cell is not allocated!\n");
1045     }
1046
1047 }
1048 static void check_range_alloced(pointer p, int n, int expect_alloced)
1049 {
1050   int i;
1051   for(i = 0;i<n;i++)
1052     { (void)check_cell_alloced(p+i,expect_alloced); }
1053 }
1054
1055 #endif
1056
1057 /* Medium level cell allocation */
1058
1059 /* get new cons cell */
1060 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
1061   pointer x = get_cell(sc,a, b);
1062
1063   typeflag(x) = T_PAIR;
1064   if(immutable) {
1065     setimmutable(x);
1066   }
1067   car(x) = a;
1068   cdr(x) = b;
1069   return (x);
1070 }
1071
1072 /* ========== oblist implementation  ========== */
1073
1074 #ifndef USE_OBJECT_LIST
1075
1076 static int hash_fn(const char *key, int table_size);
1077
1078 static pointer oblist_initial_value(scheme *sc)
1079 {
1080   return mk_vector(sc, 461); /* probably should be bigger */
1081 }
1082
1083 /* returns the new symbol */
1084 static pointer oblist_add_by_name(scheme *sc, const char *name)
1085 {
1086 #define oblist_add_by_name_allocates    3
1087   pointer x;
1088   int location;
1089
1090   gc_disable(sc, gc_reservations (oblist_add_by_name));
1091   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
1092   typeflag(x) = T_SYMBOL;
1093   setimmutable(car(x));
1094
1095   location = hash_fn(name, ivalue_unchecked(sc->oblist));
1096   set_vector_elem(sc->oblist, location,
1097                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
1098   gc_enable(sc);
1099   return x;
1100 }
1101
1102 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
1103 {
1104   int location;
1105   pointer x;
1106   char *s;
1107
1108   location = hash_fn(name, ivalue_unchecked(sc->oblist));
1109   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
1110     s = symname(car(x));
1111     /* case-insensitive, per R5RS section 2. */
1112     if(stricmp(name, s) == 0) {
1113       return car(x);
1114     }
1115   }
1116   return sc->NIL;
1117 }
1118
1119 static pointer oblist_all_symbols(scheme *sc)
1120 {
1121   int i;
1122   pointer x;
1123   pointer ob_list = sc->NIL;
1124
1125   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
1126     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
1127       ob_list = cons(sc, x, ob_list);
1128     }
1129   }
1130   return ob_list;
1131 }
1132
1133 #else
1134
1135 static pointer oblist_initial_value(scheme *sc)
1136 {
1137   return sc->NIL;
1138 }
1139
1140 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
1141 {
1142      pointer x;
1143      char    *s;
1144
1145      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
1146         s = symname(car(x));
1147         /* case-insensitive, per R5RS section 2. */
1148         if(stricmp(name, s) == 0) {
1149           return car(x);
1150         }
1151      }
1152      return sc->NIL;
1153 }
1154
1155 /* returns the new symbol */
1156 static pointer oblist_add_by_name(scheme *sc, const char *name)
1157 {
1158   pointer x;
1159
1160   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
1161   typeflag(x) = T_SYMBOL;
1162   setimmutable(car(x));
1163   sc->oblist = immutable_cons(sc, x, sc->oblist);
1164   return x;
1165 }
1166 static pointer oblist_all_symbols(scheme *sc)
1167 {
1168   return sc->oblist;
1169 }
1170
1171 #endif
1172
1173 static pointer mk_port(scheme *sc, port *p) {
1174   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1175
1176   typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
1177   x->_object._port=p;
1178   return (x);
1179 }
1180
1181 pointer mk_foreign_func(scheme *sc, foreign_func f) {
1182   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1183
1184   typeflag(x) = (T_FOREIGN | T_ATOM);
1185   x->_object._ff=f;
1186   return (x);
1187 }
1188
1189 pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
1190   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1191
1192   typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
1193   x->_object._foreign_object._vtable=vtable;
1194   x->_object._foreign_object._data = data;
1195   return (x);
1196 }
1197
1198 INTERFACE pointer mk_character(scheme *sc, int c) {
1199   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1200
1201   typeflag(x) = (T_CHARACTER | T_ATOM);
1202   ivalue_unchecked(x)= c;
1203   set_num_integer(x);
1204   return (x);
1205 }
1206
1207 \f
1208
1209 #if USE_SMALL_INTEGERS
1210
1211 /* s_save assumes that all opcodes can be expressed as a small
1212  * integer.  */
1213 #define MAX_SMALL_INTEGER       OP_MAXDEFINED
1214
1215 static int
1216 initialize_small_integers(scheme *sc)
1217 {
1218   int i;
1219   if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc,
1220                      &sc->integer_cells))
1221     return 1;
1222
1223   for (i = 0; i < MAX_SMALL_INTEGER; i++) {
1224     pointer x = &sc->integer_cells[i];
1225     typeflag(x) = T_NUMBER | T_ATOM | MARK;
1226     ivalue_unchecked(x) = i;
1227     set_num_integer(x);
1228   }
1229
1230   return 0;
1231 }
1232
1233 static INLINE pointer
1234 mk_small_integer(scheme *sc, long n)
1235 {
1236 #define mk_small_integer_allocates      0
1237   assert(0 <= n && n < MAX_SMALL_INTEGER);
1238   return &sc->integer_cells[n];
1239 }
1240 #else
1241
1242 #define mk_small_integer_allocates      1
1243 #define mk_small_integer        mk_integer
1244
1245 #endif
1246
1247 /* get number atom (integer) */
1248 INTERFACE pointer mk_integer(scheme *sc, long n) {
1249   pointer x;
1250
1251 #if USE_SMALL_INTEGERS
1252   if (0 <= n && n < MAX_SMALL_INTEGER)
1253     return mk_small_integer(sc, n);
1254 #endif
1255
1256   x = get_cell(sc,sc->NIL, sc->NIL);
1257   typeflag(x) = (T_NUMBER | T_ATOM);
1258   ivalue_unchecked(x)= n;
1259   set_num_integer(x);
1260   return (x);
1261 }
1262
1263 \f
1264
1265 INTERFACE pointer mk_real(scheme *sc, double n) {
1266   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1267
1268   typeflag(x) = (T_NUMBER | T_ATOM);
1269   rvalue_unchecked(x)= n;
1270   set_num_real(x);
1271   return (x);
1272 }
1273
1274 static pointer mk_number(scheme *sc, num n) {
1275  if(n.is_fixnum) {
1276      return mk_integer(sc,n.value.ivalue);
1277  } else {
1278      return mk_real(sc,n.value.rvalue);
1279  }
1280 }
1281
1282 /* allocate name to string area */
1283 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
1284      char *q;
1285
1286      q=(char*)sc->malloc(len_str+1);
1287      if(q==0) {
1288           sc->no_memory=1;
1289           return sc->strbuff;
1290      }
1291      if(str!=0) {
1292           memcpy (q, str, len_str);
1293           q[len_str]=0;
1294      } else {
1295           memset(q, fill, len_str);
1296           q[len_str]=0;
1297      }
1298      return (q);
1299 }
1300
1301 /* get new string */
1302 INTERFACE pointer mk_string(scheme *sc, const char *str) {
1303      return mk_counted_string(sc,str,strlen(str));
1304 }
1305
1306 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
1307      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1308      typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1309      strvalue(x) = store_string(sc,len,str,0);
1310      strlength(x) = len;
1311      return (x);
1312 }
1313
1314 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
1315      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1316      typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1317      strvalue(x) = store_string(sc,len,0,fill);
1318      strlength(x) = len;
1319      return (x);
1320 }
1321
1322 INTERFACE static pointer mk_vector(scheme *sc, int len)
1323 { return get_vector_object(sc,len,sc->NIL); }
1324
1325 INTERFACE static void fill_vector(pointer vec, pointer obj) {
1326      int i;
1327      int n = ivalue(vec)/2+ivalue(vec)%2;
1328      for(i=0; i < n; i++) {
1329           typeflag(vec+1+i) = T_PAIR;
1330           setimmutable(vec+1+i);
1331           car(vec+1+i)=obj;
1332           cdr(vec+1+i)=obj;
1333      }
1334 }
1335
1336 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1337      int n=ielem/2;
1338      if(ielem%2==0) {
1339           return car(vec+1+n);
1340      } else {
1341           return cdr(vec+1+n);
1342      }
1343 }
1344
1345 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1346      int n=ielem/2;
1347      if(ielem%2==0) {
1348           return car(vec+1+n)=a;
1349      } else {
1350           return cdr(vec+1+n)=a;
1351      }
1352 }
1353
1354 /* get new symbol */
1355 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1356 #define mk_symbol_allocates     oblist_add_by_name_allocates
1357      pointer x;
1358
1359      /* first check oblist */
1360      x = oblist_find_by_name(sc, name);
1361      if (x != sc->NIL) {
1362           return (x);
1363      } else {
1364           x = oblist_add_by_name(sc, name);
1365           return (x);
1366      }
1367 }
1368
1369 INTERFACE pointer gensym(scheme *sc) {
1370      pointer x;
1371      char name[40];
1372
1373      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1374           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1375
1376           /* first check oblist */
1377           x = oblist_find_by_name(sc, name);
1378
1379           if (x != sc->NIL) {
1380                continue;
1381           } else {
1382                x = oblist_add_by_name(sc, name);
1383                return (x);
1384           }
1385      }
1386
1387      return sc->NIL;
1388 }
1389
1390 /* double the size of the string buffer */
1391 static int expand_strbuff(scheme *sc) {
1392   size_t new_size = sc->strbuff_size * 2;
1393   char *new_buffer = sc->malloc(new_size);
1394   if (new_buffer == 0) {
1395     sc->no_memory = 1;
1396     return 1;
1397   }
1398   memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
1399   sc->free(sc->strbuff);
1400   sc->strbuff = new_buffer;
1401   sc->strbuff_size = new_size;
1402   return 0;
1403 }
1404
1405 /* make symbol or number atom from string */
1406 static pointer mk_atom(scheme *sc, char *q) {
1407      char    c, *p;
1408      int has_dec_point=0;
1409      int has_fp_exp = 0;
1410
1411 #if USE_COLON_HOOK
1412      if((p=strstr(q,"::"))!=0) {
1413           *p=0;
1414           return cons(sc, sc->COLON_HOOK,
1415                           cons(sc,
1416                               cons(sc,
1417                                    sc->QUOTE,
1418                                    cons(sc, mk_atom(sc,p+2), sc->NIL)),
1419                               cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
1420      }
1421 #endif
1422
1423      p = q;
1424      c = *p++;
1425      if ((c == '+') || (c == '-')) {
1426        c = *p++;
1427        if (c == '.') {
1428          has_dec_point=1;
1429          c = *p++;
1430        }
1431        if (!isdigit(c)) {
1432          return (mk_symbol(sc, strlwr(q)));
1433        }
1434      } else if (c == '.') {
1435        has_dec_point=1;
1436        c = *p++;
1437        if (!isdigit(c)) {
1438          return (mk_symbol(sc, strlwr(q)));
1439        }
1440      } else if (!isdigit(c)) {
1441        return (mk_symbol(sc, strlwr(q)));
1442      }
1443
1444      for ( ; (c = *p) != 0; ++p) {
1445           if (!isdigit(c)) {
1446                if(c=='.') {
1447                     if(!has_dec_point) {
1448                          has_dec_point=1;
1449                          continue;
1450                     }
1451                }
1452                else if ((c == 'e') || (c == 'E')) {
1453                        if(!has_fp_exp) {
1454                           has_dec_point = 1; /* decimal point illegal
1455                                                 from now on */
1456                           p++;
1457                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1458                              continue;
1459                           }
1460                        }
1461                }
1462                return (mk_symbol(sc, strlwr(q)));
1463           }
1464      }
1465      if(has_dec_point) {
1466           return mk_real(sc,atof(q));
1467      }
1468      return (mk_integer(sc, atol(q)));
1469 }
1470
1471 /* make constant */
1472 static pointer mk_sharp_const(scheme *sc, char *name) {
1473      long    x;
1474      char    tmp[STRBUFFSIZE];
1475
1476      if (!strcmp(name, "t"))
1477           return (sc->T);
1478      else if (!strcmp(name, "f"))
1479           return (sc->F);
1480      else if (*name == 'o') {/* #o (octal) */
1481           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1482           sscanf(tmp, "%lo", (long unsigned *)&x);
1483           return (mk_integer(sc, x));
1484      } else if (*name == 'd') {    /* #d (decimal) */
1485           sscanf(name+1, "%ld", (long int *)&x);
1486           return (mk_integer(sc, x));
1487      } else if (*name == 'x') {    /* #x (hex) */
1488           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
1489           sscanf(tmp, "%lx", (long unsigned *)&x);
1490           return (mk_integer(sc, x));
1491      } else if (*name == 'b') {    /* #b (binary) */
1492           x = binary_decode(name+1);
1493           return (mk_integer(sc, x));
1494      } else if (*name == '\\') { /* #\w (character) */
1495           int c=0;
1496           if(stricmp(name+1,"space")==0) {
1497                c=' ';
1498           } else if(stricmp(name+1,"newline")==0) {
1499                c='\n';
1500           } else if(stricmp(name+1,"return")==0) {
1501                c='\r';
1502           } else if(stricmp(name+1,"tab")==0) {
1503                c='\t';
1504      } else if(name[1]=='x' && name[2]!=0) {
1505           int c1=0;
1506           if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
1507                c=c1;
1508           } else {
1509                return sc->NIL;
1510      }
1511 #if USE_ASCII_NAMES
1512           } else if(is_ascii_name(name+1,&c)) {
1513                /* nothing */
1514 #endif
1515           } else if(name[2]==0) {
1516                c=name[1];
1517           } else {
1518                return sc->NIL;
1519           }
1520           return mk_character(sc,c);
1521      } else
1522           return (sc->NIL);
1523 }
1524
1525 /* ========== garbage collector ========== */
1526
1527 /*--
1528  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1529  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1530  *  for marking.
1531  */
1532 static void mark(pointer a) {
1533      pointer t, q, p;
1534
1535      t = (pointer) 0;
1536      p = a;
1537 E2:  setmark(p);
1538      if(is_vector(p)) {
1539           int i;
1540           int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1541           for(i=0; i < n; i++) {
1542                /* Vector cells will be treated like ordinary cells */
1543                mark(p+1+i);
1544           }
1545      }
1546      /* Mark tag if p has one.  */
1547      if (has_tag(p))
1548        mark(p + 1);
1549      if (is_atom(p))
1550           goto E6;
1551      /* E4: down car */
1552      q = car(p);
1553      if (q && !is_mark(q)) {
1554           setatom(p);  /* a note that we have moved car */
1555           car(p) = t;
1556           t = p;
1557           p = q;
1558           goto E2;
1559      }
1560 E5:  q = cdr(p); /* down cdr */
1561      if (q && !is_mark(q)) {
1562           cdr(p) = t;
1563           t = p;
1564           p = q;
1565           goto E2;
1566      }
1567 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1568      if (!t)
1569           return;
1570      q = t;
1571      if (is_atom(q)) {
1572           clratom(q);
1573           t = car(q);
1574           car(q) = p;
1575           p = q;
1576           goto E5;
1577      } else {
1578           t = cdr(q);
1579           cdr(q) = p;
1580           p = q;
1581           goto E6;
1582      }
1583 }
1584
1585 /* garbage collection. parameter a, b is marked. */
1586 static void gc(scheme *sc, pointer a, pointer b) {
1587   pointer p;
1588   int i;
1589
1590   assert (gc_enabled (sc));
1591
1592   if(sc->gc_verbose) {
1593     putstr(sc, "gc...");
1594   }
1595
1596   /* mark system globals */
1597   mark(sc->oblist);
1598   mark(sc->global_env);
1599
1600   /* mark current registers */
1601   mark(sc->args);
1602   mark(sc->envir);
1603   mark(sc->code);
1604   history_mark(sc);
1605   dump_stack_mark(sc);
1606   mark(sc->value);
1607   mark(sc->inport);
1608   mark(sc->save_inport);
1609   mark(sc->outport);
1610   mark(sc->loadport);
1611
1612   /* Mark recent objects the interpreter doesn't know about yet. */
1613   mark(car(sc->sink));
1614   /* Mark any older stuff above nested C calls */
1615   mark(sc->c_nest);
1616
1617   /* mark variables a, b */
1618   mark(a);
1619   mark(b);
1620
1621   /* garbage collect */
1622   clrmark(sc->NIL);
1623   sc->fcells = 0;
1624   sc->free_cell = sc->NIL;
1625   /* free-list is kept sorted by address so as to maintain consecutive
1626      ranges, if possible, for use with vectors. Here we scan the cells
1627      (which are also kept sorted by address) downwards to build the
1628      free-list in sorted order.
1629   */
1630   for (i = sc->last_cell_seg; i >= 0; i--) {
1631     p = sc->cell_seg[i] + CELL_SEGSIZE;
1632     while (--p >= sc->cell_seg[i]) {
1633       if (is_mark(p)) {
1634     clrmark(p);
1635       } else {
1636     /* reclaim cell */
1637         if (typeflag(p) & T_FINALIZE) {
1638           finalize_cell(sc, p);
1639         }
1640         ++sc->fcells;
1641         typeflag(p) = 0;
1642         car(p) = sc->NIL;
1643         cdr(p) = sc->free_cell;
1644         sc->free_cell = p;
1645       }
1646     }
1647   }
1648
1649   if (sc->gc_verbose) {
1650     char msg[80];
1651     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1652     putstr(sc,msg);
1653   }
1654 }
1655
1656 static void finalize_cell(scheme *sc, pointer a) {
1657   if(is_string(a)) {
1658     sc->free(strvalue(a));
1659   } else if(is_port(a)) {
1660     if(a->_object._port->kind&port_file
1661        && a->_object._port->rep.stdio.closeit) {
1662       port_close(sc,a,port_input|port_output);
1663     } else if (a->_object._port->kind & port_srfi6) {
1664       sc->free(a->_object._port->rep.string.start);
1665     }
1666     sc->free(a->_object._port);
1667   } else if(is_foreign_object(a)) {
1668     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1669   }
1670 }
1671
1672 /* ========== Routines for Reading ========== */
1673
1674 static int file_push(scheme *sc, const char *fname) {
1675   FILE *fin = NULL;
1676
1677   if (sc->file_i == MAXFIL-1)
1678      return 0;
1679   fin=fopen(fname,"r");
1680   if(fin!=0) {
1681     sc->file_i++;
1682     sc->load_stack[sc->file_i].kind=port_file|port_input;
1683     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1684     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1685     sc->nesting_stack[sc->file_i]=0;
1686     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1687
1688 #if SHOW_ERROR_LINE
1689     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1690     if(fname)
1691       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1692 #endif
1693   }
1694   return fin!=0;
1695 }
1696
1697 static void file_pop(scheme *sc) {
1698  if(sc->file_i != 0) {
1699    sc->nesting=sc->nesting_stack[sc->file_i];
1700    port_close(sc,sc->loadport,port_input);
1701    sc->file_i--;
1702    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1703  }
1704 }
1705
1706 static int file_interactive(scheme *sc) {
1707  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1708      && sc->inport->_object._port->kind&port_file;
1709 }
1710
1711 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1712   FILE *f;
1713   char *rw;
1714   port *pt;
1715   if(prop==(port_input|port_output)) {
1716     rw="a+";
1717   } else if(prop==port_output) {
1718     rw="w";
1719   } else {
1720     rw="r";
1721   }
1722   f=fopen(fn,rw);
1723   if(f==0) {
1724     return 0;
1725   }
1726   pt=port_rep_from_file(sc,f,prop);
1727   pt->rep.stdio.closeit=1;
1728
1729 #if SHOW_ERROR_LINE
1730   if(fn)
1731     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1732
1733   pt->rep.stdio.curr_line = 0;
1734 #endif
1735   return pt;
1736 }
1737
1738 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1739   port *pt;
1740   pt=port_rep_from_filename(sc,fn,prop);
1741   if(pt==0) {
1742     return sc->NIL;
1743   }
1744   return mk_port(sc,pt);
1745 }
1746
1747 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1748 {
1749     port *pt;
1750
1751     pt = (port *)sc->malloc(sizeof *pt);
1752     if (pt == NULL) {
1753         return NULL;
1754     }
1755     pt->kind = port_file | prop;
1756     pt->rep.stdio.file = f;
1757     pt->rep.stdio.closeit = 0;
1758     return pt;
1759 }
1760
1761 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1762   port *pt;
1763   pt=port_rep_from_file(sc,f,prop);
1764   if(pt==0) {
1765     return sc->NIL;
1766   }
1767   return mk_port(sc,pt);
1768 }
1769
1770 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1771   port *pt;
1772   pt=(port*)sc->malloc(sizeof(port));
1773   if(pt==0) {
1774     return 0;
1775   }
1776   pt->kind=port_string|prop;
1777   pt->rep.string.start=start;
1778   pt->rep.string.curr=start;
1779   pt->rep.string.past_the_end=past_the_end;
1780   return pt;
1781 }
1782
1783 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1784   port *pt;
1785   pt=port_rep_from_string(sc,start,past_the_end,prop);
1786   if(pt==0) {
1787     return sc->NIL;
1788   }
1789   return mk_port(sc,pt);
1790 }
1791
1792 #define BLOCK_SIZE 256
1793
1794 static port *port_rep_from_scratch(scheme *sc) {
1795   port *pt;
1796   char *start;
1797   pt=(port*)sc->malloc(sizeof(port));
1798   if(pt==0) {
1799     return 0;
1800   }
1801   start=sc->malloc(BLOCK_SIZE);
1802   if(start==0) {
1803     return 0;
1804   }
1805   memset(start,' ',BLOCK_SIZE-1);
1806   start[BLOCK_SIZE-1]='\0';
1807   pt->kind=port_string|port_output|port_srfi6;
1808   pt->rep.string.start=start;
1809   pt->rep.string.curr=start;
1810   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1811   return pt;
1812 }
1813
1814 static pointer port_from_scratch(scheme *sc) {
1815   port *pt;
1816   pt=port_rep_from_scratch(sc);
1817   if(pt==0) {
1818     return sc->NIL;
1819   }
1820   return mk_port(sc,pt);
1821 }
1822
1823 static void port_close(scheme *sc, pointer p, int flag) {
1824   port *pt=p->_object._port;
1825   pt->kind&=~flag;
1826   if((pt->kind & (port_input|port_output))==0) {
1827     if(pt->kind&port_file) {
1828
1829 #if SHOW_ERROR_LINE
1830       /* Cleanup is here so (close-*-port) functions could work too */
1831       pt->rep.stdio.curr_line = 0;
1832
1833       if(pt->rep.stdio.filename)
1834         sc->free(pt->rep.stdio.filename);
1835 #endif
1836
1837       fclose(pt->rep.stdio.file);
1838     }
1839     pt->kind=port_free;
1840   }
1841 }
1842
1843 /* get new character from input file */
1844 static int inchar(scheme *sc) {
1845   int c;
1846   port *pt;
1847
1848   pt = sc->inport->_object._port;
1849   if(pt->kind & port_saw_EOF)
1850     { return EOF; }
1851   c = basic_inchar(pt);
1852   if(c == EOF && sc->inport == sc->loadport) {
1853     /* Instead, set port_saw_EOF */
1854     pt->kind |= port_saw_EOF;
1855
1856     /* file_pop(sc); */
1857     return EOF;
1858     /* NOTREACHED */
1859   }
1860   return c;
1861 }
1862
1863 static int basic_inchar(port *pt) {
1864   if(pt->kind & port_file) {
1865     return fgetc(pt->rep.stdio.file);
1866   } else {
1867     if(*pt->rep.string.curr == 0 ||
1868        pt->rep.string.curr == pt->rep.string.past_the_end) {
1869       return EOF;
1870     } else {
1871       return *pt->rep.string.curr++;
1872     }
1873   }
1874 }
1875
1876 /* back character to input buffer */
1877 static void backchar(scheme *sc, int c) {
1878   port *pt;
1879   if(c==EOF) return;
1880   pt=sc->inport->_object._port;
1881   if(pt->kind&port_file) {
1882     ungetc(c,pt->rep.stdio.file);
1883   } else {
1884     if(pt->rep.string.curr!=pt->rep.string.start) {
1885       --pt->rep.string.curr;
1886     }
1887   }
1888 }
1889
1890 static int realloc_port_string(scheme *sc, port *p)
1891 {
1892   char *start=p->rep.string.start;
1893   size_t old_size = p->rep.string.past_the_end - start;
1894   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1895   char *str=sc->malloc(new_size);
1896   if(str) {
1897     memset(str,' ',new_size-1);
1898     str[new_size-1]='\0';
1899     memcpy(str, start, old_size);
1900     p->rep.string.start=str;
1901     p->rep.string.past_the_end=str+new_size-1;
1902     p->rep.string.curr-=start-str;
1903     sc->free(start);
1904     return 1;
1905   } else {
1906     return 0;
1907   }
1908 }
1909
1910 INTERFACE void putstr(scheme *sc, const char *s) {
1911   port *pt=sc->outport->_object._port;
1912   if(pt->kind&port_file) {
1913     fputs(s,pt->rep.stdio.file);
1914   } else {
1915     for(;*s;s++) {
1916       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1917         *pt->rep.string.curr++=*s;
1918       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1919         *pt->rep.string.curr++=*s;
1920       }
1921     }
1922   }
1923 }
1924
1925 static void putchars(scheme *sc, const char *s, int len) {
1926   port *pt=sc->outport->_object._port;
1927   if(pt->kind&port_file) {
1928     fwrite(s,1,len,pt->rep.stdio.file);
1929   } else {
1930     for(;len;len--) {
1931       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1932         *pt->rep.string.curr++=*s++;
1933       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1934         *pt->rep.string.curr++=*s++;
1935       }
1936     }
1937   }
1938 }
1939
1940 INTERFACE void putcharacter(scheme *sc, int c) {
1941   port *pt=sc->outport->_object._port;
1942   if(pt->kind&port_file) {
1943     fputc(c,pt->rep.stdio.file);
1944   } else {
1945     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1946       *pt->rep.string.curr++=c;
1947     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1948         *pt->rep.string.curr++=c;
1949     }
1950   }
1951 }
1952
1953 /* read characters up to delimiter, but cater to character constants */
1954 static char *readstr_upto(scheme *sc, char *delim) {
1955   char *p = sc->strbuff;
1956
1957   while ((p - sc->strbuff < sc->strbuff_size) &&
1958          !is_one_of(delim, (*p++ = inchar(sc))));
1959
1960   if(p == sc->strbuff+2 && p[-2] == '\\') {
1961     *p=0;
1962   } else {
1963     backchar(sc,p[-1]);
1964     *--p = '\0';
1965   }
1966   return sc->strbuff;
1967 }
1968
1969 /* read string expression "xxx...xxx" */
1970 static pointer readstrexp(scheme *sc) {
1971   char *p = sc->strbuff;
1972   int c;
1973   int c1=0;
1974   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1975
1976   for (;;) {
1977     c=inchar(sc);
1978     if(c == EOF) {
1979       return sc->F;
1980     }
1981     if(p-sc->strbuff > (sc->strbuff_size)-1) {
1982       ptrdiff_t offset = p - sc->strbuff;
1983       if (expand_strbuff(sc) != 0) {
1984         return sc->F;
1985       }
1986       p = sc->strbuff + offset;
1987     }
1988     switch(state) {
1989         case st_ok:
1990             switch(c) {
1991                 case '\\':
1992                     state=st_bsl;
1993                     break;
1994                 case '"':
1995                     *p=0;
1996                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1997                 default:
1998                     *p++=c;
1999                     break;
2000             }
2001             break;
2002         case st_bsl:
2003             switch(c) {
2004                 case '0':
2005                 case '1':
2006                 case '2':
2007                 case '3':
2008                 case '4':
2009                 case '5':
2010                 case '6':
2011                 case '7':
2012                         state=st_oct1;
2013                         c1=c-'0';
2014                         break;
2015                 case 'x':
2016                 case 'X':
2017                     state=st_x1;
2018                     c1=0;
2019                     break;
2020                 case 'n':
2021                     *p++='\n';
2022                     state=st_ok;
2023                     break;
2024                 case 't':
2025                     *p++='\t';
2026                     state=st_ok;
2027                     break;
2028                 case 'r':
2029                     *p++='\r';
2030                     state=st_ok;
2031                     break;
2032                 case '"':
2033                     *p++='"';
2034                     state=st_ok;
2035                     break;
2036                 default:
2037                     *p++=c;
2038                     state=st_ok;
2039                     break;
2040             }
2041             break;
2042         case st_x1:
2043         case st_x2:
2044             c=toupper(c);
2045             if(c>='0' && c<='F') {
2046                 if(c<='9') {
2047                     c1=(c1<<4)+c-'0';
2048                 } else {
2049                     c1=(c1<<4)+c-'A'+10;
2050                 }
2051                 if(state==st_x1) {
2052                     state=st_x2;
2053                 } else {
2054                     *p++=c1;
2055                     state=st_ok;
2056                 }
2057             } else {
2058                 return sc->F;
2059             }
2060             break;
2061         case st_oct1:
2062         case st_oct2:
2063             if (c < '0' || c > '7')
2064             {
2065                    *p++=c1;
2066                    backchar(sc, c);
2067                    state=st_ok;
2068             }
2069             else
2070             {
2071                 if (state==st_oct2 && c1 >= 32)
2072                     return sc->F;
2073
2074                    c1=(c1<<3)+(c-'0');
2075
2076                 if (state == st_oct1)
2077                         state=st_oct2;
2078                 else
2079                 {
2080                         *p++=c1;
2081                         state=st_ok;
2082                    }
2083             }
2084             break;
2085
2086     }
2087   }
2088 }
2089
2090 /* check c is in chars */
2091 static INLINE int is_one_of(char *s, int c) {
2092      if(c==EOF) return 1;
2093      while (*s)
2094           if (*s++ == c)
2095                return (1);
2096      return (0);
2097 }
2098
2099 /* skip white characters */
2100 static INLINE int skipspace(scheme *sc) {
2101      int c = 0, curr_line = 0;
2102
2103      do {
2104          c=inchar(sc);
2105 #if SHOW_ERROR_LINE
2106          if(c=='\n')
2107            curr_line++;
2108 #endif
2109      } while (isspace(c));
2110
2111 /* record it */
2112 #if SHOW_ERROR_LINE
2113      if (sc->load_stack[sc->file_i].kind & port_file)
2114        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
2115 #endif
2116
2117      if(c!=EOF) {
2118           backchar(sc,c);
2119       return 1;
2120      }
2121      else
2122        { return EOF; }
2123 }
2124
2125 /* get token */
2126 static int token(scheme *sc) {
2127      int c;
2128      c = skipspace(sc);
2129      if(c == EOF) { return (TOK_EOF); }
2130      switch (c=inchar(sc)) {
2131      case EOF:
2132           return (TOK_EOF);
2133      case '(':
2134           return (TOK_LPAREN);
2135      case ')':
2136           return (TOK_RPAREN);
2137      case '.':
2138           c=inchar(sc);
2139           if(is_one_of(" \n\t",c)) {
2140                return (TOK_DOT);
2141           } else {
2142                backchar(sc,c);
2143                backchar(sc,'.');
2144                return TOK_ATOM;
2145           }
2146      case '\'':
2147           return (TOK_QUOTE);
2148      case ';':
2149            while ((c=inchar(sc)) != '\n' && c!=EOF)
2150              ;
2151
2152 #if SHOW_ERROR_LINE
2153            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2154              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2155 #endif
2156
2157        if(c == EOF)
2158          { return (TOK_EOF); }
2159        else
2160          { return (token(sc));}
2161      case '"':
2162           return (TOK_DQUOTE);
2163      case BACKQUOTE:
2164           return (TOK_BQUOTE);
2165      case ',':
2166          if ((c=inchar(sc)) == '@') {
2167                return (TOK_ATMARK);
2168          } else {
2169                backchar(sc,c);
2170                return (TOK_COMMA);
2171          }
2172      case '#':
2173           c=inchar(sc);
2174           if (c == '(') {
2175                return (TOK_VEC);
2176           } else if(c == '!') {
2177                while ((c=inchar(sc)) != '\n' && c!=EOF)
2178                    ;
2179
2180 #if SHOW_ERROR_LINE
2181            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2182              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2183 #endif
2184
2185            if(c == EOF)
2186              { return (TOK_EOF); }
2187            else
2188              { return (token(sc));}
2189           } else {
2190                backchar(sc,c);
2191                if(is_one_of(" tfodxb\\",c)) {
2192                     return TOK_SHARP_CONST;
2193                } else {
2194                     return (TOK_SHARP);
2195                }
2196           }
2197      default:
2198           backchar(sc,c);
2199           return (TOK_ATOM);
2200      }
2201 }
2202
2203 /* ========== Routines for Printing ========== */
2204 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
2205
2206 static void printslashstring(scheme *sc, char *p, int len) {
2207   int i;
2208   unsigned char *s=(unsigned char*)p;
2209   putcharacter(sc,'"');
2210   for ( i=0; i<len; i++) {
2211     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
2212       putcharacter(sc,'\\');
2213       switch(*s) {
2214       case '"':
2215         putcharacter(sc,'"');
2216         break;
2217       case '\n':
2218         putcharacter(sc,'n');
2219         break;
2220       case '\t':
2221         putcharacter(sc,'t');
2222         break;
2223       case '\r':
2224         putcharacter(sc,'r');
2225         break;
2226       case '\\':
2227         putcharacter(sc,'\\');
2228         break;
2229       default: {
2230           int d=*s/16;
2231           putcharacter(sc,'x');
2232           if(d<10) {
2233             putcharacter(sc,d+'0');
2234           } else {
2235             putcharacter(sc,d-10+'A');
2236           }
2237           d=*s%16;
2238           if(d<10) {
2239             putcharacter(sc,d+'0');
2240           } else {
2241             putcharacter(sc,d-10+'A');
2242           }
2243         }
2244       }
2245     } else {
2246       putcharacter(sc,*s);
2247     }
2248     s++;
2249   }
2250   putcharacter(sc,'"');
2251 }
2252
2253
2254 /* print atoms */
2255 static void printatom(scheme *sc, pointer l, int f) {
2256   char *p;
2257   int len;
2258   atom2str(sc,l,f,&p,&len);
2259   putchars(sc,p,len);
2260 }
2261
2262
2263 /* Uses internal buffer unless string pointer is already available */
2264 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2265      char *p;
2266
2267      if (l == sc->NIL) {
2268           p = "()";
2269      } else if (l == sc->T) {
2270           p = "#t";
2271      } else if (l == sc->F) {
2272           p = "#f";
2273      } else if (l == sc->EOF_OBJ) {
2274           p = "#<EOF>";
2275      } else if (is_port(l)) {
2276           p = "#<PORT>";
2277      } else if (is_number(l)) {
2278           p = sc->strbuff;
2279           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2280               if(num_is_integer(l)) {
2281                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2282               } else {
2283                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2284                    /* r5rs says there must be a '.' (unless 'e'?) */
2285                    f = strcspn(p, ".e");
2286                    if (p[f] == 0) {
2287                         p[f] = '.'; /* not found, so add '.0' at the end */
2288                         p[f+1] = '0';
2289                         p[f+2] = 0;
2290                    }
2291               }
2292           } else {
2293               long v = ivalue(l);
2294               if (f == 16) {
2295                   if (v >= 0)
2296                     snprintf(p, STRBUFFSIZE, "%lx", v);
2297                   else
2298                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2299               } else if (f == 8) {
2300                   if (v >= 0)
2301                     snprintf(p, STRBUFFSIZE, "%lo", v);
2302                   else
2303                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2304               } else if (f == 2) {
2305                   unsigned long b = (v < 0) ? -v : v;
2306                   p = &p[STRBUFFSIZE-1];
2307                   *p = 0;
2308                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2309                   if (v < 0) *--p = '-';
2310               }
2311           }
2312      } else if (is_string(l)) {
2313           if (!f) {
2314                *pp = strvalue(l);
2315                *plen = strlength(l);
2316                return;
2317           } else { /* Hack, uses the fact that printing is needed */
2318                *pp=sc->strbuff;
2319                *plen=0;
2320                printslashstring(sc, strvalue(l), strlength(l));
2321                return;
2322           }
2323      } else if (is_character(l)) {
2324           int c=charvalue(l);
2325           p = sc->strbuff;
2326           if (!f) {
2327                p[0]=c;
2328                p[1]=0;
2329           } else {
2330                switch(c) {
2331                case ' ':
2332                     p = "#\\space";
2333                     break;
2334                case '\n':
2335                     p = "#\\newline";
2336                     break;
2337                case '\r':
2338                     p = "#\\return";
2339                     break;
2340                case '\t':
2341                     p = "#\\tab";
2342                     break;
2343                default:
2344 #if USE_ASCII_NAMES
2345                     if(c==127) {
2346                          p = "#\\del";
2347                          break;
2348                     } else if(c<32) {
2349                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2350                          break;
2351                     }
2352 #else
2353                     if(c<32) {
2354                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2355                       break;
2356                     }
2357 #endif
2358                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2359                     break;
2360                }
2361           }
2362      } else if (is_symbol(l)) {
2363           p = symname(l);
2364      } else if (is_proc(l)) {
2365           p = sc->strbuff;
2366           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2367      } else if (is_macro(l)) {
2368           p = "#<MACRO>";
2369      } else if (is_closure(l)) {
2370           p = "#<CLOSURE>";
2371      } else if (is_promise(l)) {
2372           p = "#<PROMISE>";
2373      } else if (is_foreign(l)) {
2374           p = sc->strbuff;
2375           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2376      } else if (is_continuation(l)) {
2377           p = "#<CONTINUATION>";
2378      } else if (is_foreign_object(l)) {
2379           p = sc->strbuff;
2380           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2381      } else {
2382           p = "#<ERROR>";
2383      }
2384      *pp=p;
2385      *plen=strlen(p);
2386 }
2387 /* ========== Routines for Evaluation Cycle ========== */
2388
2389 /* make closure. c is code. e is environment */
2390 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2391      pointer x = get_cell(sc, c, e);
2392
2393      typeflag(x) = T_CLOSURE;
2394      car(x) = c;
2395      cdr(x) = e;
2396      return (x);
2397 }
2398
2399 /* make continuation. */
2400 static pointer mk_continuation(scheme *sc, pointer d) {
2401      pointer x = get_cell(sc, sc->NIL, d);
2402
2403      typeflag(x) = T_CONTINUATION;
2404      cont_dump(x) = d;
2405      return (x);
2406 }
2407
2408 static pointer list_star(scheme *sc, pointer d) {
2409   pointer p, q;
2410   if(cdr(d)==sc->NIL) {
2411     return car(d);
2412   }
2413   p=cons(sc,car(d),cdr(d));
2414   q=p;
2415   while(cdr(cdr(p))!=sc->NIL) {
2416     d=cons(sc,car(p),cdr(p));
2417     if(cdr(cdr(p))!=sc->NIL) {
2418       p=cdr(d);
2419     }
2420   }
2421   cdr(p)=car(cdr(p));
2422   return q;
2423 }
2424
2425 /* reverse list -- produce new list */
2426 static pointer reverse(scheme *sc, pointer term, pointer list) {
2427 /* a must be checked by gc */
2428      pointer a = list, p = term;
2429
2430      for ( ; is_pair(a); a = cdr(a)) {
2431           p = cons(sc, car(a), p);
2432      }
2433      return (p);
2434 }
2435
2436 /* reverse list --- in-place */
2437 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2438      pointer p = list, result = term, q;
2439
2440      while (p != sc->NIL) {
2441           q = cdr(p);
2442           cdr(p) = result;
2443           result = p;
2444           p = q;
2445      }
2446      return (result);
2447 }
2448
2449 /* append list -- produce new list (in reverse order) */
2450 static pointer revappend(scheme *sc, pointer a, pointer b) {
2451     pointer result = a;
2452     pointer p = b;
2453
2454     while (is_pair(p)) {
2455         result = cons(sc, car(p), result);
2456         p = cdr(p);
2457     }
2458
2459     if (p == sc->NIL) {
2460         return result;
2461     }
2462
2463     return sc->F;   /* signal an error */
2464 }
2465
2466 /* equivalence of atoms */
2467 int eqv(pointer a, pointer b) {
2468      if (is_string(a)) {
2469           if (is_string(b))
2470                return (strvalue(a) == strvalue(b));
2471           else
2472                return (0);
2473      } else if (is_number(a)) {
2474           if (is_number(b)) {
2475                if (num_is_integer(a) == num_is_integer(b))
2476                     return num_eq(nvalue(a),nvalue(b));
2477           }
2478           return (0);
2479      } else if (is_character(a)) {
2480           if (is_character(b))
2481                return charvalue(a)==charvalue(b);
2482           else
2483                return (0);
2484      } else if (is_port(a)) {
2485           if (is_port(b))
2486                return a==b;
2487           else
2488                return (0);
2489      } else if (is_proc(a)) {
2490           if (is_proc(b))
2491                return procnum(a)==procnum(b);
2492           else
2493                return (0);
2494      } else {
2495           return (a == b);
2496      }
2497 }
2498
2499 /* true or false value macro */
2500 /* () is #t in R5RS */
2501 #define is_true(p)       ((p) != sc->F)
2502 #define is_false(p)      ((p) == sc->F)
2503
2504 /* ========== Environment implementation  ========== */
2505
2506 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2507
2508 static int hash_fn(const char *key, int table_size)
2509 {
2510   unsigned int hashed = 0;
2511   const char *c;
2512   int bits_per_int = sizeof(unsigned int)*8;
2513
2514   for (c = key; *c; c++) {
2515     /* letters have about 5 bits in them */
2516     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2517     hashed ^= *c;
2518   }
2519   return hashed % table_size;
2520 }
2521 #endif
2522
2523 #ifndef USE_ALIST_ENV
2524
2525 /*
2526  * In this implementation, each frame of the environment may be
2527  * a hash table: a vector of alists hashed by variable name.
2528  * In practice, we use a vector only for the initial frame;
2529  * subsequent frames are too small and transient for the lookup
2530  * speed to out-weigh the cost of making a new vector.
2531  */
2532
2533 static void new_frame_in_env(scheme *sc, pointer old_env)
2534 {
2535   pointer new_frame;
2536
2537   /* The interaction-environment has about 300 variables in it. */
2538   if (old_env == sc->NIL) {
2539     new_frame = mk_vector(sc, 461);
2540   } else {
2541     new_frame = sc->NIL;
2542   }
2543
2544   gc_disable(sc, 1);
2545   sc->envir = immutable_cons(sc, new_frame, old_env);
2546   gc_enable(sc);
2547   setenvironment(sc->envir);
2548 }
2549
2550 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2551                                         pointer variable, pointer value)
2552 {
2553 #define new_slot_spec_in_env_allocates  2
2554   pointer slot;
2555   gc_disable(sc, gc_reservations (new_slot_spec_in_env));
2556   slot = immutable_cons(sc, variable, value);
2557
2558   if (is_vector(car(env))) {
2559     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2560
2561     set_vector_elem(car(env), location,
2562                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2563   } else {
2564     car(env) = immutable_cons(sc, slot, car(env));
2565   }
2566   gc_enable(sc);
2567 }
2568
2569 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2570 {
2571   pointer x,y;
2572   int location;
2573
2574   for (x = env; x != sc->NIL; x = cdr(x)) {
2575     if (is_vector(car(x))) {
2576       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2577       y = vector_elem(car(x), location);
2578     } else {
2579       y = car(x);
2580     }
2581     for ( ; y != sc->NIL; y = cdr(y)) {
2582               if (caar(y) == hdl) {
2583                    break;
2584               }
2585          }
2586          if (y != sc->NIL) {
2587               break;
2588          }
2589          if(!all) {
2590            return sc->NIL;
2591          }
2592     }
2593     if (x != sc->NIL) {
2594           return car(y);
2595     }
2596     return sc->NIL;
2597 }
2598
2599 #else /* USE_ALIST_ENV */
2600
2601 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2602 {
2603   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2604   setenvironment(sc->envir);
2605 }
2606
2607 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2608                                         pointer variable, pointer value)
2609 {
2610   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2611 }
2612
2613 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2614 {
2615     pointer x,y;
2616     for (x = env; x != sc->NIL; x = cdr(x)) {
2617          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2618               if (caar(y) == hdl) {
2619                    break;
2620               }
2621          }
2622          if (y != sc->NIL) {
2623               break;
2624          }
2625          if(!all) {
2626            return sc->NIL;
2627          }
2628     }
2629     if (x != sc->NIL) {
2630           return car(y);
2631     }
2632     return sc->NIL;
2633 }
2634
2635 #endif /* USE_ALIST_ENV else */
2636
2637 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2638 {
2639 #define new_slot_in_env_allocates       new_slot_spec_in_env_allocates
2640   new_slot_spec_in_env(sc, sc->envir, variable, value);
2641 }
2642
2643 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2644 {
2645   (void)sc;
2646   cdr(slot) = value;
2647 }
2648
2649 static INLINE pointer slot_value_in_env(pointer slot)
2650 {
2651   return cdr(slot);
2652 }
2653
2654 /* ========== Evaluation Cycle ========== */
2655
2656
2657 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2658      const char *str = s;
2659 #if USE_ERROR_HOOK
2660      pointer x;
2661      pointer hdl=sc->ERROR_HOOK;
2662 #endif
2663
2664 #if SHOW_ERROR_LINE
2665      char sbuf[STRBUFFSIZE];
2666
2667      /* make sure error is not in REPL */
2668      if (sc->load_stack[sc->file_i].kind & port_file &&
2669          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2670        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2671        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2672
2673        /* should never happen */
2674        if(!fname) fname = "<unknown>";
2675
2676        /* we started from 0 */
2677        ln++;
2678        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2679
2680        str = (const char*)sbuf;
2681      }
2682 #endif
2683
2684 #if USE_ERROR_HOOK
2685      x=find_slot_in_env(sc,sc->envir,hdl,1);
2686     if (x != sc->NIL) {
2687          if(a!=0) {
2688                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2689          } else {
2690                sc->code = sc->NIL;
2691          }
2692          sc->code = cons(sc, mk_string(sc, str), sc->code);
2693          setimmutable(car(sc->code));
2694          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2695          sc->op = (int)OP_EVAL;
2696          return sc->T;
2697     }
2698 #endif
2699
2700     if(a!=0) {
2701           sc->args = cons(sc, (a), sc->NIL);
2702     } else {
2703           sc->args = sc->NIL;
2704     }
2705     sc->args = cons(sc, mk_string(sc, str), sc->args);
2706     setimmutable(car(sc->args));
2707     sc->op = (int)OP_ERR0;
2708     return sc->T;
2709 }
2710 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2711 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2712
2713 /* Too small to turn into function */
2714 # define  BEGIN     do {
2715 # define  END  } while (0)
2716
2717 \f
2718
2719 /* Flags.  The interpreter has a flags field.  When the interpreter
2720  * pushes a frame to the dump stack, it is encoded with the opcode.
2721  * Therefore, we do not use the least significant byte.  */
2722
2723 /* Masks used to encode and decode opcode and flags.  */
2724 #define S_OP_MASK       0x000000ff
2725 #define S_FLAG_MASK     0xffffff00
2726
2727 /* Set if the interpreter evaluates an expression in a tail context
2728  * (see R5RS, section 3.5).  If a function, procedure, or continuation
2729  * is invoked while this flag is set, the call is recorded as tail
2730  * call in the history buffer.  */
2731 #define S_FLAG_TAIL_CONTEXT     0x00000100
2732
2733 /* Set flag F.  */
2734 #define s_set_flag(sc, f)                       \
2735            BEGIN                                \
2736            (sc)->flags |= S_FLAG_ ## f;         \
2737            END
2738
2739 /* Clear flag F.  */
2740 #define s_clear_flag(sc, f)                     \
2741            BEGIN                                \
2742            (sc)->flags &= ~ S_FLAG_ ## f;       \
2743            END
2744
2745 /* Check if flag F is set.  */
2746 #define s_get_flag(sc, f)                       \
2747            !!((sc)->flags & S_FLAG_ ## f)
2748
2749 \f
2750
2751 /* Bounce back to Eval_Cycle and execute A.  */
2752 #define s_goto(sc,a) BEGIN                                  \
2753     sc->op = (int)(a);                                      \
2754     return sc->T; END
2755
2756 #if USE_THREADED_CODE
2757
2758 /* Do not bounce back to Eval_Cycle but execute A by jumping directly
2759  * to it.  Only applicable if A is part of the same dispatch
2760  * function.  */
2761 #define s_thread_to(sc, a)      \
2762      BEGIN                      \
2763      op = (int) (a);            \
2764      goto a;                    \
2765      END
2766
2767 /* Define a label OP and emit a case statement for OP.  For use in the
2768  * dispatch functions.  The slightly peculiar goto that is never
2769  * executed avoids warnings about unused labels.  */
2770 #define CASE(OP)        if (0) goto OP; OP: case OP
2771
2772 #else   /* USE_THREADED_CODE */
2773 #define s_thread_to(sc, a)      s_goto(sc, a)
2774 #define CASE(OP)                case OP
2775 #endif  /* USE_THREADED_CODE */
2776
2777 /* Return to the previous frame on the dump stack, setting the current
2778  * value to A.  */
2779 #define s_return(sc, a) return _s_return(sc, a, 0)
2780
2781 /* Return to the previous frame on the dump stack, setting the current
2782  * value to A, and re-enable the garbage collector.  */
2783 #define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
2784
2785 static INLINE void dump_stack_reset(scheme *sc)
2786 {
2787   sc->dump = sc->NIL;
2788 }
2789
2790 static INLINE void dump_stack_initialize(scheme *sc)
2791 {
2792   dump_stack_reset(sc);
2793 }
2794
2795 static void dump_stack_free(scheme *sc)
2796 {
2797   sc->dump = sc->NIL;
2798 }
2799
2800 static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
2801   pointer dump = sc->dump;
2802   pointer op;
2803   unsigned long v;
2804   sc->value = (a);
2805   if (enable_gc)
2806        gc_enable(sc);
2807   if (dump == sc->NIL)
2808     return sc->NIL;
2809   free_cons(sc, dump, &op, &dump);
2810   v = (unsigned long) ivalue_unchecked(op);
2811   sc->op = (int) (v & S_OP_MASK);
2812   sc->flags = v & S_FLAG_MASK;
2813 #ifdef USE_SMALL_INTEGERS
2814   if (v < MAX_SMALL_INTEGER) {
2815     /* This is a small integer, we must not free it.  */
2816   } else
2817     /* Normal integer.  Recover the cell.  */
2818 #endif
2819     free_cell(sc, op);
2820   free_cons(sc, dump, &sc->args, &dump);
2821   free_cons(sc, dump, &sc->envir, &dump);
2822   free_cons(sc, dump, &sc->code, &sc->dump);
2823   return sc->T;
2824 }
2825
2826 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2827 #define s_save_allocates        5
2828     pointer dump;
2829     unsigned long v = sc->flags | ((unsigned long) op);
2830     gc_disable(sc, gc_reservations (s_save));
2831     dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2832     dump = cons(sc, (args), dump);
2833     sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
2834     gc_enable(sc);
2835 }
2836
2837 static INLINE void dump_stack_mark(scheme *sc)
2838 {
2839   mark(sc->dump);
2840 }
2841
2842 \f
2843
2844 #if USE_HISTORY
2845
2846 static void
2847 history_free(scheme *sc)
2848 {
2849   sc->free(sc->history.m);
2850   sc->history.tailstacks = sc->NIL;
2851   sc->history.callstack = sc->NIL;
2852 }
2853
2854 static pointer
2855 history_init(scheme *sc, size_t N, size_t M)
2856 {
2857   size_t i;
2858   struct history *h = &sc->history;
2859
2860   h->N = N;
2861   h->mask_N = N - 1;
2862   h->n = N - 1;
2863   assert ((N & h->mask_N) == 0);
2864
2865   h->M = M;
2866   h->mask_M = M - 1;
2867   assert ((M & h->mask_M) == 0);
2868
2869   h->callstack = mk_vector(sc, N);
2870   if (h->callstack == sc->sink)
2871     goto fail;
2872
2873   h->tailstacks = mk_vector(sc, N);
2874   for (i = 0; i < N; i++) {
2875     pointer tailstack = mk_vector(sc, M);
2876     if (tailstack == sc->sink)
2877       goto fail;
2878     set_vector_elem(h->tailstacks, i, tailstack);
2879   }
2880
2881   h->m = sc->malloc(N * sizeof *h->m);
2882   if (h->m == NULL)
2883     goto fail;
2884
2885   for (i = 0; i < N; i++)
2886     h->m[i] = 0;
2887
2888   return sc->T;
2889
2890 fail:
2891   history_free(sc);
2892   return sc->F;
2893 }
2894
2895 static void
2896 history_mark(scheme *sc)
2897 {
2898   struct history *h = &sc->history;
2899   mark(h->callstack);
2900   mark(h->tailstacks);
2901 }
2902
2903 #define add_mod(a, b, mask)     (((a) + (b)) & (mask))
2904 #define sub_mod(a, b, mask)     add_mod(a, (mask) + 1 - (b), mask)
2905
2906 static INLINE void
2907 tailstack_clear(scheme *sc, pointer v)
2908 {
2909   assert(is_vector(v));
2910   /* XXX optimize */
2911   fill_vector(v, sc->NIL);
2912 }
2913
2914 static pointer
2915 callstack_pop(scheme *sc)
2916 {
2917   struct history *h = &sc->history;
2918   size_t n = h->n;
2919   pointer item;
2920
2921   if (h->callstack == sc->NIL)
2922     return sc->NIL;
2923
2924   item = vector_elem(h->callstack, n);
2925   /* Clear our frame so that it can be gc'ed and we don't run into it
2926    * when walking the history.  */
2927   set_vector_elem(h->callstack, n, sc->NIL);
2928   tailstack_clear(sc, vector_elem(h->tailstacks, n));
2929
2930   /* Exit from the frame.  */
2931   h->n = sub_mod(h->n, 1, h->mask_N);
2932
2933   return item;
2934 }
2935
2936 static void
2937 callstack_push(scheme *sc, pointer item)
2938 {
2939   struct history *h = &sc->history;
2940   size_t n = h->n;
2941
2942   if (h->callstack == sc->NIL)
2943     return;
2944
2945   /* Enter a new frame.  */
2946   n = h->n = add_mod(n, 1, h->mask_N);
2947
2948   /* Initialize tail stack.  */
2949   tailstack_clear(sc, vector_elem(h->tailstacks, n));
2950   h->m[n] = h->mask_M;
2951
2952   set_vector_elem(h->callstack, n, item);
2953 }
2954
2955 static void
2956 tailstack_push(scheme *sc, pointer item)
2957 {
2958   struct history *h = &sc->history;
2959   size_t n = h->n;
2960   size_t m = h->m[n];
2961
2962   if (h->callstack == sc->NIL)
2963     return;
2964
2965   /* Enter a new tail frame.  */
2966   m = h->m[n] = add_mod(m, 1, h->mask_M);
2967   set_vector_elem(vector_elem(h->tailstacks, n), m, item);
2968 }
2969
2970 static pointer
2971 tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
2972                   pointer acc)
2973 {
2974   struct history *h = &sc->history;
2975   pointer frame;
2976
2977   assert(i <= h->M);
2978   assert(n < h->M);
2979
2980   if (acc == sc->sink)
2981     return sc->sink;
2982
2983   if (i == 0) {
2984     /* We reached the end, but we did not see a unused frame.  Signal
2985        this using '... .  */
2986     return cons(sc, mk_symbol(sc, "..."), acc);
2987   }
2988
2989   frame = vector_elem(tailstack, n);
2990   if (frame == sc->NIL) {
2991     /* A unused frame.  We reached the end of the history.  */
2992     return acc;
2993   }
2994
2995   /* Add us.  */
2996   acc = cons(sc, frame, acc);
2997
2998   return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
2999                            acc);
3000 }
3001
3002 static pointer
3003 callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
3004 {
3005   struct history *h = &sc->history;
3006   pointer frame;
3007
3008   assert(i <= h->N);
3009   assert(n < h->N);
3010
3011   if (acc == sc->sink)
3012     return sc->sink;
3013
3014   if (i == 0) {
3015     /* We reached the end, but we did not see a unused frame.  Signal
3016        this using '... .  */
3017     return cons(sc, mk_symbol(sc, "..."), acc);
3018   }
3019
3020   frame = vector_elem(h->callstack, n);
3021   if (frame == sc->NIL) {
3022     /* A unused frame.  We reached the end of the history.  */
3023     return acc;
3024   }
3025
3026   /* First, emit the tail calls.  */
3027   acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
3028                           acc);
3029
3030   /* Then us.  */
3031   acc = cons(sc, frame, acc);
3032
3033   return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
3034 }
3035
3036 static pointer
3037 history_flatten(scheme *sc)
3038 {
3039   struct history *h = &sc->history;
3040   pointer history;
3041
3042   if (h->callstack == sc->NIL)
3043     return sc->NIL;
3044
3045   history = callstack_flatten(sc, h->N, h->n, sc->NIL);
3046   if (history == sc->sink)
3047     return sc->sink;
3048
3049   return reverse_in_place(sc, sc->NIL, history);
3050 }
3051
3052 #undef add_mod
3053 #undef sub_mod
3054
3055 #else   /* USE_HISTORY */
3056
3057 #define history_init(SC, A, B)  (void) 0
3058 #define history_free(SC)        (void) 0
3059 #define callstack_pop(SC)       (void) 0
3060 #define callstack_push(SC, X)   (void) 0
3061 #define tailstack_push(SC, X)   (void) 0
3062
3063 #endif  /* USE_HISTORY */
3064
3065 \f
3066
3067 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
3068
3069 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
3070      pointer x, y;
3071      pointer callsite;
3072
3073      switch (op) {
3074      CASE(OP_LOAD):       /* load */
3075           if(file_interactive(sc)) {
3076                fprintf(sc->outport->_object._port->rep.stdio.file,
3077                "Loading %s\n", strvalue(car(sc->args)));
3078           }
3079           if (!file_push(sc,strvalue(car(sc->args)))) {
3080                Error_1(sc,"unable to open", car(sc->args));
3081           }
3082       else
3083         {
3084           sc->args = mk_integer(sc,sc->file_i);
3085           s_thread_to(sc,OP_T0LVL);
3086         }
3087
3088      CASE(OP_T0LVL): /* top level */
3089        /* If we reached the end of file, this loop is done. */
3090        if(sc->loadport->_object._port->kind & port_saw_EOF)
3091      {
3092        if(sc->file_i == 0)
3093          {
3094            sc->args=sc->NIL;
3095            sc->nesting = sc->nesting_stack[0];
3096            s_goto(sc,OP_QUIT);
3097          }
3098        else
3099          {
3100            file_pop(sc);
3101            s_return(sc,sc->value);
3102          }
3103        /* NOTREACHED */
3104      }
3105
3106        /* If interactive, be nice to user. */
3107        if(file_interactive(sc))
3108      {
3109        sc->envir = sc->global_env;
3110        dump_stack_reset(sc);
3111        putstr(sc,"\n");
3112        putstr(sc,prompt);
3113      }
3114
3115        /* Set up another iteration of REPL */
3116        sc->nesting=0;
3117        sc->save_inport=sc->inport;
3118        sc->inport = sc->loadport;
3119        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
3120        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
3121        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
3122        s_thread_to(sc,OP_READ_INTERNAL);
3123
3124      CASE(OP_T1LVL): /* top level */
3125           sc->code = sc->value;
3126           sc->inport=sc->save_inport;
3127           s_thread_to(sc,OP_EVAL);
3128
3129      CASE(OP_READ_INTERNAL):       /* internal read */
3130           sc->tok = token(sc);
3131           if(sc->tok==TOK_EOF)
3132         { s_return(sc,sc->EOF_OBJ); }
3133           s_goto(sc,OP_RDSEXPR);
3134
3135      CASE(OP_GENSYM):
3136           s_return(sc, gensym(sc));
3137
3138      CASE(OP_VALUEPRINT): /* print evaluation result */
3139           /* OP_VALUEPRINT is always pushed, because when changing from
3140              non-interactive to interactive mode, it needs to be
3141              already on the stack */
3142        if(sc->tracing) {
3143          putstr(sc,"\nGives: ");
3144        }
3145        if(file_interactive(sc)) {
3146          sc->print_flag = 1;
3147          sc->args = sc->value;
3148          s_goto(sc,OP_P0LIST);
3149        } else {
3150          s_return(sc,sc->value);
3151        }
3152
3153      CASE(OP_EVAL):       /* main part of evaluation */
3154 #if USE_TRACING
3155        if(sc->tracing) {
3156          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
3157          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
3158          sc->args=sc->code;
3159          putstr(sc,"\nEval: ");
3160          s_goto(sc,OP_P0LIST);
3161        }
3162        /* fall through */
3163      CASE(OP_REAL_EVAL):
3164 #endif
3165           if (is_symbol(sc->code)) {    /* symbol */
3166                x=find_slot_in_env(sc,sc->envir,sc->code,1);
3167                if (x != sc->NIL) {
3168                     s_return(sc,slot_value_in_env(x));
3169                } else {
3170                     Error_1(sc,"eval: unbound variable:", sc->code);
3171                }
3172           } else if (is_pair(sc->code)) {
3173                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
3174                     sc->code = cdr(sc->code);
3175                     s_goto(sc,syntaxnum(x));
3176                } else {/* first, eval top element and eval arguments */
3177                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
3178                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
3179                     sc->code = car(sc->code);
3180                     s_clear_flag(sc, TAIL_CONTEXT);
3181                     s_thread_to(sc,OP_EVAL);
3182                }
3183           } else {
3184                s_return(sc,sc->code);
3185           }
3186
3187      CASE(OP_E0ARGS):     /* eval arguments */
3188           if (is_macro(sc->value)) {    /* macro expansion */
3189                gc_disable(sc, 1 + gc_reservations (s_save));
3190                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
3191                sc->args = cons(sc,sc->code, sc->NIL);
3192                gc_enable(sc);
3193                sc->code = sc->value;
3194                s_clear_flag(sc, TAIL_CONTEXT);
3195                s_thread_to(sc,OP_APPLY);
3196           } else {
3197                gc_disable(sc, 1);
3198                sc->args = cons(sc, sc->code, sc->NIL);
3199                gc_enable(sc);
3200                sc->code = cdr(sc->code);
3201                s_thread_to(sc,OP_E1ARGS);
3202           }
3203
3204      CASE(OP_E1ARGS):     /* eval arguments */
3205           gc_disable(sc, 1);
3206           sc->args = cons(sc, sc->value, sc->args);
3207           gc_enable(sc);
3208           if (is_pair(sc->code)) { /* continue */
3209                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
3210                sc->code = car(sc->code);
3211                sc->args = sc->NIL;
3212                s_clear_flag(sc, TAIL_CONTEXT);
3213                s_thread_to(sc,OP_EVAL);
3214           } else {  /* end */
3215                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3216                s_thread_to(sc,OP_APPLY_CODE);
3217           }
3218
3219 #if USE_TRACING
3220      CASE(OP_TRACING): {
3221        int tr=sc->tracing;
3222        sc->tracing=ivalue(car(sc->args));
3223        gc_disable(sc, 1);
3224        s_return_enable_gc(sc, mk_integer(sc, tr));
3225      }
3226 #endif
3227
3228 #if USE_HISTORY
3229      CASE(OP_CALLSTACK_POP):      /* pop the call stack */
3230           callstack_pop(sc);
3231           s_return(sc, sc->value);
3232 #endif
3233
3234      CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
3235                            * record in the history as invoked from
3236                            * 'car(args)' */
3237           free_cons(sc, sc->args, &callsite, &sc->args);
3238           sc->code = car(sc->args);
3239           sc->args = cdr(sc->args);
3240           /* Fallthrough.  */
3241
3242      CASE(OP_APPLY):      /* apply 'code' to 'args' */
3243 #if USE_TRACING
3244        if(sc->tracing) {
3245          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
3246          sc->print_flag = 1;
3247          /*  sc->args=cons(sc,sc->code,sc->args);*/
3248          putstr(sc,"\nApply to: ");
3249          s_goto(sc,OP_P0LIST);
3250        }
3251        /* fall through */
3252      CASE(OP_REAL_APPLY):
3253 #endif
3254 #if USE_HISTORY
3255           if (op != OP_APPLY_CODE)
3256             callsite = sc->code;
3257           if (s_get_flag(sc, TAIL_CONTEXT)) {
3258             /* We are evaluating a tail call.  */
3259             tailstack_push(sc, callsite);
3260           } else {
3261             callstack_push(sc, callsite);
3262             s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
3263           }
3264 #endif
3265
3266           if (is_proc(sc->code)) {
3267                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
3268           } else if (is_foreign(sc->code))
3269             {
3270               /* Keep nested calls from GC'ing the arglist */
3271               push_recent_alloc(sc,sc->args,sc->NIL);
3272                x=sc->code->_object._ff(sc,sc->args);
3273                s_return(sc,x);
3274           } else if (is_closure(sc->code) || is_macro(sc->code)
3275              || is_promise(sc->code)) { /* CLOSURE */
3276         /* Should not accept promise */
3277                /* make environment */
3278                new_frame_in_env(sc, closure_env(sc->code));
3279                for (x = car(closure_code(sc->code)), y = sc->args;
3280                     is_pair(x); x = cdr(x), y = cdr(y)) {
3281                     if (y == sc->NIL) {
3282                          Error_1(sc, "not enough arguments, missing:", x);
3283                     } else {
3284                          new_slot_in_env(sc, car(x), car(y));
3285                     }
3286                }
3287                if (x == sc->NIL) {
3288                     /*--
3289                      * if (y != sc->NIL) {
3290                      *   Error_0(sc,"too many arguments");
3291                      * }
3292                      */
3293                } else if (is_symbol(x))
3294                     new_slot_in_env(sc, x, y);
3295                else {
3296                     Error_1(sc,"syntax error in closure: not a symbol:", x);
3297                }
3298                sc->code = cdr(closure_code(sc->code));
3299                sc->args = sc->NIL;
3300                s_set_flag(sc, TAIL_CONTEXT);
3301                s_thread_to(sc,OP_BEGIN);
3302           } else if (is_continuation(sc->code)) { /* CONTINUATION */
3303                sc->dump = cont_dump(sc->code);
3304                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
3305           } else {
3306                Error_1(sc,"illegal function",sc->code);
3307           }
3308
3309      CASE(OP_DOMACRO):    /* do macro */
3310           sc->code = sc->value;
3311           s_thread_to(sc,OP_EVAL);
3312
3313 #if USE_COMPILE_HOOK
3314      CASE(OP_LAMBDA):     /* lambda */
3315           /* If the hook is defined, apply it to sc->code, otherwise
3316              set sc->value fall through */
3317           {
3318                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
3319                if(f==sc->NIL) {
3320                     sc->value = sc->code;
3321                     /* Fallthru */
3322                } else {
3323                     gc_disable(sc, 1 + gc_reservations (s_save));
3324                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
3325                     sc->args=cons(sc,sc->code,sc->NIL);
3326                     gc_enable(sc);
3327                     sc->code=slot_value_in_env(f);
3328                     s_thread_to(sc,OP_APPLY);
3329                }
3330           }
3331
3332 #else
3333      CASE(OP_LAMBDA):     /* lambda */
3334           sc->value = sc->code;
3335           /* Fallthrough. */
3336 #endif
3337
3338      CASE(OP_LAMBDA1):
3339           gc_disable(sc, 1);
3340           s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
3341
3342
3343      CASE(OP_MKCLOSURE): /* make-closure */
3344        x=car(sc->args);
3345        if(car(x)==sc->LAMBDA) {
3346          x=cdr(x);
3347        }
3348        if(cdr(sc->args)==sc->NIL) {
3349          y=sc->envir;
3350        } else {
3351          y=cadr(sc->args);
3352        }
3353        gc_disable(sc, 1);
3354        s_return_enable_gc(sc, mk_closure(sc, x, y));
3355
3356      CASE(OP_QUOTE):      /* quote */
3357           s_return(sc,car(sc->code));
3358
3359      CASE(OP_DEF0):  /* define */
3360           if(is_immutable(car(sc->code)))
3361             Error_1(sc,"define: unable to alter immutable", car(sc->code));
3362
3363           if (is_pair(car(sc->code))) {
3364                x = caar(sc->code);
3365                gc_disable(sc, 2);
3366                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3367                gc_enable(sc);
3368           } else {
3369                x = car(sc->code);
3370                sc->code = cadr(sc->code);
3371           }
3372           if (!is_symbol(x)) {
3373                Error_0(sc,"variable is not a symbol");
3374           }
3375           s_save(sc,OP_DEF1, sc->NIL, x);
3376           s_thread_to(sc,OP_EVAL);
3377
3378      CASE(OP_DEF1):  /* define */
3379           x=find_slot_in_env(sc,sc->envir,sc->code,0);
3380           if (x != sc->NIL) {
3381                set_slot_in_env(sc, x, sc->value);
3382           } else {
3383                new_slot_in_env(sc, sc->code, sc->value);
3384           }
3385           s_return(sc,sc->code);
3386
3387
3388      CASE(OP_DEFP):  /* defined? */
3389           x=sc->envir;
3390           if(cdr(sc->args)!=sc->NIL) {
3391                x=cadr(sc->args);
3392           }
3393           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3394
3395      CASE(OP_SET0):       /* set! */
3396           if(is_immutable(car(sc->code)))
3397                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3398           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3399           sc->code = cadr(sc->code);
3400           s_thread_to(sc,OP_EVAL);
3401
3402      CASE(OP_SET1):       /* set! */
3403           y=find_slot_in_env(sc,sc->envir,sc->code,1);
3404           if (y != sc->NIL) {
3405                set_slot_in_env(sc, y, sc->value);
3406                s_return(sc,sc->value);
3407           } else {
3408                Error_1(sc,"set!: unbound variable:", sc->code);
3409           }
3410
3411
3412      CASE(OP_BEGIN):      /* begin */
3413           {
3414             int last;
3415
3416             if (!is_pair(sc->code)) {
3417               s_return(sc,sc->code);
3418             }
3419
3420             last = cdr(sc->code) == sc->NIL;
3421             if (!last) {
3422               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3423             }
3424             sc->code = car(sc->code);
3425             if (! last)
3426               /* This is not the end of the list.  This is not a tail
3427                * position.  */
3428               s_clear_flag(sc, TAIL_CONTEXT);
3429             s_thread_to(sc,OP_EVAL);
3430           }
3431
3432      CASE(OP_IF0):        /* if */
3433           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3434           sc->code = car(sc->code);
3435           s_clear_flag(sc, TAIL_CONTEXT);
3436           s_thread_to(sc,OP_EVAL);
3437
3438      CASE(OP_IF1):        /* if */
3439           if (is_true(sc->value))
3440                sc->code = car(sc->code);
3441           else
3442                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
3443                                             * car(sc->NIL) = sc->NIL */
3444           s_thread_to(sc,OP_EVAL);
3445
3446      CASE(OP_LET0):       /* let */
3447           sc->args = sc->NIL;
3448           sc->value = sc->code;
3449           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3450           s_thread_to(sc,OP_LET1);
3451
3452      CASE(OP_LET1):       /* let (calculate parameters) */
3453           gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3454           sc->args = cons(sc, sc->value, sc->args);
3455           if (is_pair(sc->code)) { /* continue */
3456                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3457                     gc_enable(sc);
3458                     Error_1(sc, "Bad syntax of binding spec in let :",
3459                             car(sc->code));
3460                }
3461                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
3462                gc_enable(sc);
3463                sc->code = cadar(sc->code);
3464                sc->args = sc->NIL;
3465                s_clear_flag(sc, TAIL_CONTEXT);
3466                s_thread_to(sc,OP_EVAL);
3467           } else {  /* end */
3468                gc_enable(sc);
3469                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3470                sc->code = car(sc->args);
3471                sc->args = cdr(sc->args);
3472                s_thread_to(sc,OP_LET2);
3473           }
3474
3475      CASE(OP_LET2):       /* let */
3476           new_frame_in_env(sc, sc->envir);
3477           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
3478                y != sc->NIL; x = cdr(x), y = cdr(y)) {
3479                new_slot_in_env(sc, caar(x), car(y));
3480           }
3481           if (is_symbol(car(sc->code))) {    /* named let */
3482                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
3483                     if (!is_pair(x))
3484                         Error_1(sc, "Bad syntax of binding in let :", x);
3485                     if (!is_list(sc, car(x)))
3486                         Error_1(sc, "Bad syntax of binding in let :", car(x));
3487                     gc_disable(sc, 1);
3488                     sc->args = cons(sc, caar(x), sc->args);
3489                     gc_enable(sc);
3490                }
3491                gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
3492                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
3493                new_slot_in_env(sc, car(sc->code), x);
3494                gc_enable(sc);
3495                sc->code = cddr(sc->code);
3496                sc->args = sc->NIL;
3497           } else {
3498                sc->code = cdr(sc->code);
3499                sc->args = sc->NIL;
3500           }
3501           s_thread_to(sc,OP_BEGIN);
3502
3503      CASE(OP_LET0AST):    /* let* */
3504           if (car(sc->code) == sc->NIL) {
3505                new_frame_in_env(sc, sc->envir);
3506                sc->code = cdr(sc->code);
3507                s_thread_to(sc,OP_BEGIN);
3508           }
3509           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
3510                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
3511           }
3512           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
3513           sc->code = cadaar(sc->code);
3514           s_clear_flag(sc, TAIL_CONTEXT);
3515           s_thread_to(sc,OP_EVAL);
3516
3517      CASE(OP_LET1AST):    /* let* (make new frame) */
3518           new_frame_in_env(sc, sc->envir);
3519           s_thread_to(sc,OP_LET2AST);
3520
3521      CASE(OP_LET2AST):    /* let* (calculate parameters) */
3522           new_slot_in_env(sc, caar(sc->code), sc->value);
3523           sc->code = cdr(sc->code);
3524           if (is_pair(sc->code)) { /* continue */
3525                s_save(sc,OP_LET2AST, sc->args, sc->code);
3526                sc->code = cadar(sc->code);
3527                sc->args = sc->NIL;
3528                s_clear_flag(sc, TAIL_CONTEXT);
3529                s_thread_to(sc,OP_EVAL);
3530           } else {  /* end */
3531                sc->code = sc->args;
3532                sc->args = sc->NIL;
3533                s_thread_to(sc,OP_BEGIN);
3534           }
3535      default:
3536           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3537           Error_0(sc,sc->strbuff);
3538      }
3539      return sc->T;
3540 }
3541
3542 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
3543      pointer x, y;
3544
3545      switch (op) {
3546      CASE(OP_LET0REC):    /* letrec */
3547           new_frame_in_env(sc, sc->envir);
3548           sc->args = sc->NIL;
3549           sc->value = sc->code;
3550           sc->code = car(sc->code);
3551           s_thread_to(sc,OP_LET1REC);
3552
3553      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
3554           gc_disable(sc, 1);
3555           sc->args = cons(sc, sc->value, sc->args);
3556           gc_enable(sc);
3557           if (is_pair(sc->code)) { /* continue */
3558                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3559                     Error_1(sc, "Bad syntax of binding spec in letrec :",
3560                             car(sc->code));
3561                }
3562                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
3563                sc->code = cadar(sc->code);
3564                sc->args = sc->NIL;
3565                s_clear_flag(sc, TAIL_CONTEXT);
3566                s_goto(sc,OP_EVAL);
3567           } else {  /* end */
3568                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3569                sc->code = car(sc->args);
3570                sc->args = cdr(sc->args);
3571                s_thread_to(sc,OP_LET2REC);
3572           }
3573
3574      CASE(OP_LET2REC):    /* letrec */
3575           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
3576                new_slot_in_env(sc, caar(x), car(y));
3577           }
3578           sc->code = cdr(sc->code);
3579           sc->args = sc->NIL;
3580           s_goto(sc,OP_BEGIN);
3581
3582      CASE(OP_COND0):      /* cond */
3583           if (!is_pair(sc->code)) {
3584                Error_0(sc,"syntax error in cond");
3585           }
3586           s_save(sc,OP_COND1, sc->NIL, sc->code);
3587           sc->code = caar(sc->code);
3588           s_clear_flag(sc, TAIL_CONTEXT);
3589           s_goto(sc,OP_EVAL);
3590
3591      CASE(OP_COND1):      /* cond */
3592           if (is_true(sc->value)) {
3593                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3594                     s_return(sc,sc->value);
3595                }
3596                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3597                     if(!is_pair(cdr(sc->code))) {
3598                          Error_0(sc,"syntax error in cond");
3599                     }
3600                     gc_disable(sc, 4);
3601                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3602                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3603                     gc_enable(sc);
3604                     s_goto(sc,OP_EVAL);
3605                }
3606                s_goto(sc,OP_BEGIN);
3607           } else {
3608                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3609                     s_return(sc,sc->NIL);
3610                } else {
3611                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3612                     sc->code = caar(sc->code);
3613                     s_clear_flag(sc, TAIL_CONTEXT);
3614         &n