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