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