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