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