gpg,common: Make sure that all fd given are valid.
[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           if (pt->kind & port_file) {
1582                mark(pt->rep.stdio.curr_line);
1583                mark(pt->rep.stdio.filename);
1584           }
1585      }
1586 #endif
1587      /* Mark tag if p has one.  */
1588      if (has_tag(p))
1589        mark(p + 1);
1590      if (is_atom(p))
1591           goto E6;
1592      /* E4: down car */
1593      q = car(p);
1594      if (q && !is_mark(q)) {
1595           setatom(p);  /* a note that we have moved car */
1596           car(p) = t;
1597           t = p;
1598           p = q;
1599           goto E2;
1600      }
1601 E5:  q = cdr(p); /* down cdr */
1602      if (q && !is_mark(q)) {
1603           cdr(p) = t;
1604           t = p;
1605           p = q;
1606           goto E2;
1607      }
1608 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1609      if (!t)
1610           return;
1611      q = t;
1612      if (is_atom(q)) {
1613           clratom(q);
1614           t = car(q);
1615           car(q) = p;
1616           p = q;
1617           goto E5;
1618      } else {
1619           t = cdr(q);
1620           cdr(q) = p;
1621           p = q;
1622           goto E6;
1623      }
1624 }
1625
1626 /* garbage collection. parameter a, b is marked. */
1627 static void gc(scheme *sc, pointer a, pointer b) {
1628   pointer p;
1629   int i;
1630
1631   assert (gc_enabled (sc));
1632
1633   if(sc->gc_verbose) {
1634     putstr(sc, "gc...");
1635   }
1636
1637   /* mark system globals */
1638   mark(sc->oblist);
1639   mark(sc->global_env);
1640
1641   /* mark current registers */
1642   mark(sc->args);
1643   mark(sc->envir);
1644   mark(sc->code);
1645   history_mark(sc);
1646   dump_stack_mark(sc);
1647   mark(sc->value);
1648   mark(sc->inport);
1649   mark(sc->save_inport);
1650   mark(sc->outport);
1651   mark(sc->loadport);
1652   for (i = 0; i <= sc->file_i; i++) {
1653     if (! (sc->load_stack[i].kind & port_file))
1654       continue;
1655
1656     mark(sc->load_stack[i].rep.stdio.filename);
1657     mark(sc->load_stack[i].rep.stdio.curr_line);
1658   }
1659
1660   /* Mark recent objects the interpreter doesn't know about yet. */
1661   mark(car(sc->sink));
1662   /* Mark any older stuff above nested C calls */
1663   mark(sc->c_nest);
1664
1665   /* mark variables a, b */
1666   mark(a);
1667   mark(b);
1668
1669   /* garbage collect */
1670   clrmark(sc->NIL);
1671   sc->fcells = 0;
1672   sc->free_cell = sc->NIL;
1673   /* free-list is kept sorted by address so as to maintain consecutive
1674      ranges, if possible, for use with vectors. Here we scan the cells
1675      (which are also kept sorted by address) downwards to build the
1676      free-list in sorted order.
1677   */
1678   for (i = sc->last_cell_seg; i >= 0; i--) {
1679     p = sc->cell_seg[i] + CELL_SEGSIZE;
1680     while (--p >= sc->cell_seg[i]) {
1681       if (typeflag(p) & IMMEDIATE_TAG)
1682         continue;
1683       if (is_mark(p)) {
1684     clrmark(p);
1685       } else {
1686     /* reclaim cell */
1687         if (typeflag(p) & T_FINALIZE) {
1688           finalize_cell(sc, p);
1689         }
1690         ++sc->fcells;
1691         typeflag(p) = 0;
1692         car(p) = sc->NIL;
1693         cdr(p) = sc->free_cell;
1694         sc->free_cell = p;
1695       }
1696     }
1697   }
1698
1699   if (sc->gc_verbose) {
1700     char msg[80];
1701     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1702     putstr(sc,msg);
1703   }
1704 }
1705
1706 static void finalize_cell(scheme *sc, pointer a) {
1707   if(is_string(a)) {
1708     sc->free(strvalue(a));
1709   } else if(is_port(a)) {
1710     if(a->_object._port->kind&port_file
1711        && a->_object._port->rep.stdio.closeit) {
1712       port_close(sc,a,port_input|port_output);
1713     } else if (a->_object._port->kind & port_srfi6) {
1714       sc->free(a->_object._port->rep.string.start);
1715     }
1716     sc->free(a->_object._port);
1717   } else if(is_foreign_object(a)) {
1718     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1719   } else if (is_vector(a)) {
1720     int i;
1721     for (i = vector_size(vector_length(a)) - 1; i > 0; i--) {
1722       pointer p = a + i;
1723       typeflag(p) = 0;
1724       car(p) = sc->NIL;
1725       cdr(p) = sc->free_cell;
1726       sc->free_cell = p;
1727       sc->fcells += 1;
1728     }
1729   }
1730 }
1731
1732 #if SHOW_ERROR_LINE
1733 static void
1734 port_clear_location (scheme *sc, port *p)
1735 {
1736   assert(p->kind & port_file);
1737   p->rep.stdio.curr_line = sc->NIL;
1738   p->rep.stdio.filename = sc->NIL;
1739 }
1740
1741 static void
1742 port_reset_current_line (scheme *sc, port *p)
1743 {
1744   assert(p->kind & port_file);
1745   p->rep.stdio.curr_line = mk_integer(sc, 0);
1746 }
1747
1748 static void
1749 port_increment_current_line (scheme *sc, port *p, long delta)
1750 {
1751   assert(p->kind & port_file);
1752   p->rep.stdio.curr_line =
1753     mk_integer(sc, ivalue_unchecked(p->rep.stdio.curr_line) + delta);
1754 }
1755 #endif
1756
1757 /* ========== Routines for Reading ========== */
1758
1759 static int file_push(scheme *sc, pointer fname) {
1760   FILE *fin = NULL;
1761
1762   if (sc->file_i == MAXFIL-1)
1763      return 0;
1764   fin = fopen(string_value(fname), "r");
1765   if(fin!=0) {
1766     sc->file_i++;
1767     sc->load_stack[sc->file_i].kind=port_file|port_input;
1768     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1769     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1770     sc->nesting_stack[sc->file_i]=0;
1771     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1772
1773 #if SHOW_ERROR_LINE
1774     port_reset_current_line(sc, &sc->load_stack[sc->file_i]);
1775     sc->load_stack[sc->file_i].rep.stdio.filename = fname;
1776 #endif
1777   }
1778   return fin!=0;
1779 }
1780
1781 static void file_pop(scheme *sc) {
1782  if(sc->file_i != 0) {
1783    sc->nesting=sc->nesting_stack[sc->file_i];
1784    port_close(sc,sc->loadport,port_input);
1785 #if SHOW_ERROR_LINE
1786    if (sc->load_stack[sc->file_i].kind & port_file)
1787      port_clear_location(sc, &sc->load_stack[sc->file_i]);
1788 #endif
1789    sc->file_i--;
1790    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1791  }
1792 }
1793
1794 static int file_interactive(scheme *sc) {
1795  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1796      && sc->inport->_object._port->kind&port_file;
1797 }
1798
1799 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1800   FILE *f;
1801   char *rw;
1802   port *pt;
1803   if(prop==(port_input|port_output)) {
1804     rw="a+";
1805   } else if(prop==port_output) {
1806     rw="w";
1807   } else {
1808     rw="r";
1809   }
1810   f=fopen(fn,rw);
1811   if(f==0) {
1812     return 0;
1813   }
1814   pt=port_rep_from_file(sc,f,prop);
1815   pt->rep.stdio.closeit=1;
1816
1817 #if SHOW_ERROR_LINE
1818   if (fn)
1819     pt->rep.stdio.filename = mk_string(sc, fn);
1820   else
1821     pt->rep.stdio.filename = mk_string(sc, "<unknown>");
1822
1823   port_reset_current_line(sc, pt);
1824 #endif
1825   return pt;
1826 }
1827
1828 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1829   port *pt;
1830   pt=port_rep_from_filename(sc,fn,prop);
1831   if(pt==0) {
1832     return sc->NIL;
1833   }
1834   return mk_port(sc,pt);
1835 }
1836
1837 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1838 {
1839     port *pt;
1840
1841     pt = (port *)sc->malloc(sizeof *pt);
1842     if (pt == NULL) {
1843         return NULL;
1844     }
1845     pt->kind = port_file | prop;
1846     pt->rep.stdio.file = f;
1847     pt->rep.stdio.closeit = 0;
1848 #if SHOW_ERROR_LINE
1849     pt->rep.stdio.filename = mk_string(sc, "<unknown>");
1850     port_reset_current_line(sc, pt);
1851 #endif
1852     return pt;
1853 }
1854
1855 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1856   port *pt;
1857   pt=port_rep_from_file(sc,f,prop);
1858   if(pt==0) {
1859     return sc->NIL;
1860   }
1861   return mk_port(sc,pt);
1862 }
1863
1864 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1865   port *pt;
1866   pt=(port*)sc->malloc(sizeof(port));
1867   if(pt==0) {
1868     return 0;
1869   }
1870   pt->kind=port_string|prop;
1871   pt->rep.string.start=start;
1872   pt->rep.string.curr=start;
1873   pt->rep.string.past_the_end=past_the_end;
1874   return pt;
1875 }
1876
1877 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1878   port *pt;
1879   pt=port_rep_from_string(sc,start,past_the_end,prop);
1880   if(pt==0) {
1881     return sc->NIL;
1882   }
1883   return mk_port(sc,pt);
1884 }
1885
1886 #define BLOCK_SIZE 256
1887
1888 static port *port_rep_from_scratch(scheme *sc) {
1889   port *pt;
1890   char *start;
1891   pt=(port*)sc->malloc(sizeof(port));
1892   if(pt==0) {
1893     return 0;
1894   }
1895   start=sc->malloc(BLOCK_SIZE);
1896   if(start==0) {
1897     return 0;
1898   }
1899   memset(start,' ',BLOCK_SIZE-1);
1900   start[BLOCK_SIZE-1]='\0';
1901   pt->kind=port_string|port_output|port_srfi6;
1902   pt->rep.string.start=start;
1903   pt->rep.string.curr=start;
1904   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1905   return pt;
1906 }
1907
1908 static pointer port_from_scratch(scheme *sc) {
1909   port *pt;
1910   pt=port_rep_from_scratch(sc);
1911   if(pt==0) {
1912     return sc->NIL;
1913   }
1914   return mk_port(sc,pt);
1915 }
1916
1917 static void port_close(scheme *sc, pointer p, int flag) {
1918   port *pt=p->_object._port;
1919   pt->kind&=~flag;
1920   if((pt->kind & (port_input|port_output))==0) {
1921     if(pt->kind&port_file) {
1922
1923 #if SHOW_ERROR_LINE
1924       /* Cleanup is here so (close-*-port) functions could work too */
1925       port_clear_location(sc, pt);
1926 #endif
1927
1928       fclose(pt->rep.stdio.file);
1929     }
1930     pt->kind=port_free;
1931   }
1932 }
1933
1934 /* get new character from input file */
1935 static int inchar(scheme *sc) {
1936   int c;
1937   port *pt;
1938
1939   pt = sc->inport->_object._port;
1940   if(pt->kind & port_saw_EOF)
1941     { return EOF; }
1942   c = basic_inchar(pt);
1943   if(c == EOF && sc->inport == sc->loadport) {
1944     /* Instead, set port_saw_EOF */
1945     pt->kind |= port_saw_EOF;
1946
1947     /* file_pop(sc); */
1948     return EOF;
1949     /* NOTREACHED */
1950   }
1951   return c;
1952 }
1953
1954 static int basic_inchar(port *pt) {
1955   if(pt->kind & port_file) {
1956     return fgetc(pt->rep.stdio.file);
1957   } else {
1958     if(*pt->rep.string.curr == 0 ||
1959        pt->rep.string.curr == pt->rep.string.past_the_end) {
1960       return EOF;
1961     } else {
1962       return *pt->rep.string.curr++;
1963     }
1964   }
1965 }
1966
1967 /* back character to input buffer */
1968 static void backchar(scheme *sc, int c) {
1969   port *pt;
1970   if(c==EOF) return;
1971   pt=sc->inport->_object._port;
1972   if(pt->kind&port_file) {
1973     ungetc(c,pt->rep.stdio.file);
1974   } else {
1975     if(pt->rep.string.curr!=pt->rep.string.start) {
1976       --pt->rep.string.curr;
1977     }
1978   }
1979 }
1980
1981 static int realloc_port_string(scheme *sc, port *p)
1982 {
1983   char *start=p->rep.string.start;
1984   size_t old_size = p->rep.string.past_the_end - start;
1985   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1986   char *str=sc->malloc(new_size);
1987   if(str) {
1988     memset(str,' ',new_size-1);
1989     str[new_size-1]='\0';
1990     memcpy(str, start, old_size);
1991     p->rep.string.start=str;
1992     p->rep.string.past_the_end=str+new_size-1;
1993     p->rep.string.curr-=start-str;
1994     sc->free(start);
1995     return 1;
1996   } else {
1997     return 0;
1998   }
1999 }
2000
2001 INTERFACE void putstr(scheme *sc, const char *s) {
2002   port *pt=sc->outport->_object._port;
2003   if(pt->kind&port_file) {
2004     fputs(s,pt->rep.stdio.file);
2005   } else {
2006     for(;*s;s++) {
2007       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
2008         *pt->rep.string.curr++=*s;
2009       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
2010         *pt->rep.string.curr++=*s;
2011       }
2012     }
2013   }
2014 }
2015
2016 static void putchars(scheme *sc, const char *s, int len) {
2017   port *pt=sc->outport->_object._port;
2018   if(pt->kind&port_file) {
2019     fwrite(s,1,len,pt->rep.stdio.file);
2020   } else {
2021     for(;len;len--) {
2022       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
2023         *pt->rep.string.curr++=*s++;
2024       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
2025         *pt->rep.string.curr++=*s++;
2026       }
2027     }
2028   }
2029 }
2030
2031 INTERFACE void putcharacter(scheme *sc, int c) {
2032   port *pt=sc->outport->_object._port;
2033   if(pt->kind&port_file) {
2034     fputc(c,pt->rep.stdio.file);
2035   } else {
2036     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
2037       *pt->rep.string.curr++=c;
2038     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
2039         *pt->rep.string.curr++=c;
2040     }
2041   }
2042 }
2043
2044 /* read characters up to delimiter, but cater to character constants */
2045 static char *readstr_upto(scheme *sc, char *delim) {
2046   char *p = sc->strbuff;
2047
2048   while ((p - sc->strbuff < sc->strbuff_size) &&
2049          !is_one_of(delim, (*p++ = inchar(sc))));
2050
2051   if(p == sc->strbuff+2 && p[-2] == '\\') {
2052     *p=0;
2053   } else {
2054     backchar(sc,p[-1]);
2055     *--p = '\0';
2056   }
2057   return sc->strbuff;
2058 }
2059
2060 /* read string expression "xxx...xxx" */
2061 static pointer readstrexp(scheme *sc) {
2062   char *p = sc->strbuff;
2063   int c;
2064   int c1=0;
2065   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
2066
2067   for (;;) {
2068     c=inchar(sc);
2069     if(c == EOF) {
2070       return sc->F;
2071     }
2072     if(p-sc->strbuff > (sc->strbuff_size)-1) {
2073       ptrdiff_t offset = p - sc->strbuff;
2074       if (expand_strbuff(sc) != 0) {
2075         return sc->F;
2076       }
2077       p = sc->strbuff + offset;
2078     }
2079     switch(state) {
2080         case st_ok:
2081             switch(c) {
2082                 case '\\':
2083                     state=st_bsl;
2084                     break;
2085                 case '"':
2086                     *p=0;
2087                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
2088                 default:
2089                     *p++=c;
2090                     break;
2091             }
2092             break;
2093         case st_bsl:
2094             switch(c) {
2095                 case '0':
2096                 case '1':
2097                 case '2':
2098                 case '3':
2099                 case '4':
2100                 case '5':
2101                 case '6':
2102                 case '7':
2103                         state=st_oct1;
2104                         c1=c-'0';
2105                         break;
2106                 case 'x':
2107                 case 'X':
2108                     state=st_x1;
2109                     c1=0;
2110                     break;
2111                 case 'n':
2112                     *p++='\n';
2113                     state=st_ok;
2114                     break;
2115                 case 't':
2116                     *p++='\t';
2117                     state=st_ok;
2118                     break;
2119                 case 'r':
2120                     *p++='\r';
2121                     state=st_ok;
2122                     break;
2123                 case '"':
2124                     *p++='"';
2125                     state=st_ok;
2126                     break;
2127                 default:
2128                     *p++=c;
2129                     state=st_ok;
2130                     break;
2131             }
2132             break;
2133         case st_x1:
2134         case st_x2:
2135             c=toupper(c);
2136             if(c>='0' && c<='F') {
2137                 if(c<='9') {
2138                     c1=(c1<<4)+c-'0';
2139                 } else {
2140                     c1=(c1<<4)+c-'A'+10;
2141                 }
2142                 if(state==st_x1) {
2143                     state=st_x2;
2144                 } else {
2145                     *p++=c1;
2146                     state=st_ok;
2147                 }
2148             } else {
2149                 return sc->F;
2150             }
2151             break;
2152         case st_oct1:
2153         case st_oct2:
2154             if (c < '0' || c > '7')
2155             {
2156                    *p++=c1;
2157                    backchar(sc, c);
2158                    state=st_ok;
2159             }
2160             else
2161             {
2162                 if (state==st_oct2 && c1 >= 32)
2163                     return sc->F;
2164
2165                    c1=(c1<<3)+(c-'0');
2166
2167                 if (state == st_oct1)
2168                         state=st_oct2;
2169                 else
2170                 {
2171                         *p++=c1;
2172                         state=st_ok;
2173                    }
2174             }
2175             break;
2176
2177     }
2178   }
2179 }
2180
2181 /* check c is in chars */
2182 static INLINE int is_one_of(char *s, int c) {
2183      if(c==EOF) return 1;
2184      while (*s)
2185           if (*s++ == c)
2186                return (1);
2187      return (0);
2188 }
2189
2190 /* skip white characters */
2191 static INLINE int skipspace(scheme *sc) {
2192      int c = 0, curr_line = 0;
2193
2194      do {
2195          c=inchar(sc);
2196 #if SHOW_ERROR_LINE
2197          if(c=='\n')
2198            curr_line++;
2199 #endif
2200      } while (isspace(c));
2201
2202 /* record it */
2203 #if SHOW_ERROR_LINE
2204      {
2205        port *p = &sc->load_stack[sc->file_i];
2206        if (p->kind & port_file)
2207          port_increment_current_line(sc, p, curr_line);
2208      }
2209 #endif
2210
2211      if(c!=EOF) {
2212           backchar(sc,c);
2213       return 1;
2214      }
2215      else
2216        { return EOF; }
2217 }
2218
2219 /* get token */
2220 static int token(scheme *sc) {
2221      int c;
2222      c = skipspace(sc);
2223      if(c == EOF) { return (TOK_EOF); }
2224      switch (c=inchar(sc)) {
2225      case EOF:
2226           return (TOK_EOF);
2227      case '(':
2228           return (TOK_LPAREN);
2229      case ')':
2230           return (TOK_RPAREN);
2231      case '.':
2232           c=inchar(sc);
2233           if(is_one_of(" \n\t",c)) {
2234                return (TOK_DOT);
2235           } else {
2236                backchar(sc,c);
2237                backchar(sc,'.');
2238                return TOK_ATOM;
2239           }
2240      case '\'':
2241           return (TOK_QUOTE);
2242      case ';':
2243            while ((c=inchar(sc)) != '\n' && c!=EOF)
2244              ;
2245
2246 #if SHOW_ERROR_LINE
2247            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2248              port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
2249 #endif
2250
2251        if(c == EOF)
2252          { return (TOK_EOF); }
2253        else
2254          { return (token(sc));}
2255      case '"':
2256           return (TOK_DQUOTE);
2257      case BACKQUOTE:
2258           return (TOK_BQUOTE);
2259      case ',':
2260          if ((c=inchar(sc)) == '@') {
2261                return (TOK_ATMARK);
2262          } else {
2263                backchar(sc,c);
2264                return (TOK_COMMA);
2265          }
2266      case '#':
2267           c=inchar(sc);
2268           if (c == '(') {
2269                return (TOK_VEC);
2270           } else if(c == '!') {
2271                while ((c=inchar(sc)) != '\n' && c!=EOF)
2272                    ;
2273
2274 #if SHOW_ERROR_LINE
2275            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2276              port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
2277 #endif
2278
2279            if(c == EOF)
2280              { return (TOK_EOF); }
2281            else
2282              { return (token(sc));}
2283           } else {
2284                backchar(sc,c);
2285                if(is_one_of(" tfodxb\\",c)) {
2286                     return TOK_SHARP_CONST;
2287                } else {
2288                     return (TOK_SHARP);
2289                }
2290           }
2291      default:
2292           backchar(sc,c);
2293           return (TOK_ATOM);
2294      }
2295 }
2296
2297 /* ========== Routines for Printing ========== */
2298 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
2299
2300 static void printslashstring(scheme *sc, char *p, int len) {
2301   int i;
2302   unsigned char *s=(unsigned char*)p;
2303   putcharacter(sc,'"');
2304   for ( i=0; i<len; i++) {
2305     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
2306       putcharacter(sc,'\\');
2307       switch(*s) {
2308       case '"':
2309         putcharacter(sc,'"');
2310         break;
2311       case '\n':
2312         putcharacter(sc,'n');
2313         break;
2314       case '\t':
2315         putcharacter(sc,'t');
2316         break;
2317       case '\r':
2318         putcharacter(sc,'r');
2319         break;
2320       case '\\':
2321         putcharacter(sc,'\\');
2322         break;
2323       default: {
2324           int d=*s/16;
2325           putcharacter(sc,'x');
2326           if(d<10) {
2327             putcharacter(sc,d+'0');
2328           } else {
2329             putcharacter(sc,d-10+'A');
2330           }
2331           d=*s%16;
2332           if(d<10) {
2333             putcharacter(sc,d+'0');
2334           } else {
2335             putcharacter(sc,d-10+'A');
2336           }
2337         }
2338       }
2339     } else {
2340       putcharacter(sc,*s);
2341     }
2342     s++;
2343   }
2344   putcharacter(sc,'"');
2345 }
2346
2347
2348 /* print atoms */
2349 static void printatom(scheme *sc, pointer l, int f) {
2350   char *p;
2351   int len;
2352   atom2str(sc,l,f,&p,&len);
2353   putchars(sc,p,len);
2354 }
2355
2356
2357 /* Uses internal buffer unless string pointer is already available */
2358 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2359      char *p;
2360
2361      if (l == sc->NIL) {
2362           p = "()";
2363      } else if (l == sc->T) {
2364           p = "#t";
2365      } else if (l == sc->F) {
2366           p = "#f";
2367      } else if (l == sc->EOF_OBJ) {
2368           p = "#<EOF>";
2369      } else if (is_port(l)) {
2370           p = "#<PORT>";
2371      } else if (is_number(l)) {
2372           p = sc->strbuff;
2373           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2374               if(num_is_integer(l)) {
2375                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2376               } else {
2377                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2378                    /* r5rs says there must be a '.' (unless 'e'?) */
2379                    f = strcspn(p, ".e");
2380                    if (p[f] == 0) {
2381                         p[f] = '.'; /* not found, so add '.0' at the end */
2382                         p[f+1] = '0';
2383                         p[f+2] = 0;
2384                    }
2385               }
2386           } else {
2387               long v = ivalue(l);
2388               if (f == 16) {
2389                   if (v >= 0)
2390                     snprintf(p, STRBUFFSIZE, "%lx", v);
2391                   else
2392                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2393               } else if (f == 8) {
2394                   if (v >= 0)
2395                     snprintf(p, STRBUFFSIZE, "%lo", v);
2396                   else
2397                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2398               } else if (f == 2) {
2399                   unsigned long b = (v < 0) ? -v : v;
2400                   p = &p[STRBUFFSIZE-1];
2401                   *p = 0;
2402                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2403                   if (v < 0) *--p = '-';
2404               }
2405           }
2406      } else if (is_string(l)) {
2407           if (!f) {
2408                *pp = strvalue(l);
2409                *plen = strlength(l);
2410                return;
2411           } else { /* Hack, uses the fact that printing is needed */
2412                *pp=sc->strbuff;
2413                *plen=0;
2414                printslashstring(sc, strvalue(l), strlength(l));
2415                return;
2416           }
2417      } else if (is_character(l)) {
2418           int c=charvalue(l);
2419           p = sc->strbuff;
2420           if (!f) {
2421                p[0]=c;
2422                p[1]=0;
2423           } else {
2424                switch(c) {
2425                case ' ':
2426                     p = "#\\space";
2427                     break;
2428                case '\n':
2429                     p = "#\\newline";
2430                     break;
2431                case '\r':
2432                     p = "#\\return";
2433                     break;
2434                case '\t':
2435                     p = "#\\tab";
2436                     break;
2437                default:
2438 #if USE_ASCII_NAMES
2439                     if(c==127) {
2440                          p = "#\\del";
2441                          break;
2442                     } else if(c<32) {
2443                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2444                          break;
2445                     }
2446 #else
2447                     if(c<32) {
2448                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2449                       break;
2450                     }
2451 #endif
2452                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2453                     break;
2454                }
2455           }
2456      } else if (is_symbol(l)) {
2457           p = symname(l);
2458      } else if (is_proc(l)) {
2459           p = sc->strbuff;
2460           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2461      } else if (is_macro(l)) {
2462           p = "#<MACRO>";
2463      } else if (is_closure(l)) {
2464           p = "#<CLOSURE>";
2465      } else if (is_promise(l)) {
2466           p = "#<PROMISE>";
2467      } else if (is_foreign(l)) {
2468           p = sc->strbuff;
2469           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2470      } else if (is_continuation(l)) {
2471           p = "#<CONTINUATION>";
2472      } else if (is_foreign_object(l)) {
2473           p = sc->strbuff;
2474           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2475      } else {
2476           p = "#<ERROR>";
2477      }
2478      *pp=p;
2479      *plen=strlen(p);
2480 }
2481 /* ========== Routines for Evaluation Cycle ========== */
2482
2483 /* make closure. c is code. e is environment */
2484 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2485      pointer x = get_cell(sc, c, e);
2486
2487      typeflag(x) = T_CLOSURE;
2488      car(x) = c;
2489      cdr(x) = e;
2490      return (x);
2491 }
2492
2493 /* make continuation. */
2494 static pointer mk_continuation(scheme *sc, pointer d) {
2495      pointer x = get_cell(sc, sc->NIL, d);
2496
2497      typeflag(x) = T_CONTINUATION;
2498      cont_dump(x) = d;
2499      return (x);
2500 }
2501
2502 static pointer list_star(scheme *sc, pointer d) {
2503   pointer p, q;
2504   if(cdr(d)==sc->NIL) {
2505     return car(d);
2506   }
2507   p=cons(sc,car(d),cdr(d));
2508   q=p;
2509   while(cdr(cdr(p))!=sc->NIL) {
2510     d=cons(sc,car(p),cdr(p));
2511     if(cdr(cdr(p))!=sc->NIL) {
2512       p=cdr(d);
2513     }
2514   }
2515   cdr(p)=car(cdr(p));
2516   return q;
2517 }
2518
2519 /* reverse list -- produce new list */
2520 static pointer reverse(scheme *sc, pointer term, pointer list) {
2521 /* a must be checked by gc */
2522      pointer a = list, p = term;
2523
2524      for ( ; is_pair(a); a = cdr(a)) {
2525           p = cons(sc, car(a), p);
2526      }
2527      return (p);
2528 }
2529
2530 /* reverse list --- in-place */
2531 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2532      pointer p = list, result = term, q;
2533
2534      while (p != sc->NIL) {
2535           q = cdr(p);
2536           cdr(p) = result;
2537           result = p;
2538           p = q;
2539      }
2540      return (result);
2541 }
2542
2543 /* append list -- produce new list (in reverse order) */
2544 static pointer revappend(scheme *sc, pointer a, pointer b) {
2545     pointer result = a;
2546     pointer p = b;
2547
2548     while (is_pair(p)) {
2549         result = cons(sc, car(p), result);
2550         p = cdr(p);
2551     }
2552
2553     if (p == sc->NIL) {
2554         return result;
2555     }
2556
2557     return sc->F;   /* signal an error */
2558 }
2559
2560 /* equivalence of atoms */
2561 int eqv(pointer a, pointer b) {
2562      if (is_string(a)) {
2563           if (is_string(b))
2564                return (strvalue(a) == strvalue(b));
2565           else
2566                return (0);
2567      } else if (is_number(a)) {
2568           if (is_number(b)) {
2569                if (num_is_integer(a) == num_is_integer(b))
2570                     return num_eq(nvalue(a),nvalue(b));
2571           }
2572           return (0);
2573      } else if (is_character(a)) {
2574           if (is_character(b))
2575                return charvalue(a)==charvalue(b);
2576           else
2577                return (0);
2578      } else if (is_port(a)) {
2579           if (is_port(b))
2580                return a==b;
2581           else
2582                return (0);
2583      } else if (is_proc(a)) {
2584           if (is_proc(b))
2585                return procnum(a)==procnum(b);
2586           else
2587                return (0);
2588      } else {
2589           return (a == b);
2590      }
2591 }
2592
2593 /* true or false value macro */
2594 /* () is #t in R5RS */
2595 #define is_true(p)       ((p) != sc->F)
2596 #define is_false(p)      ((p) == sc->F)
2597
2598 /* ========== Environment implementation  ========== */
2599
2600 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2601
2602 static int hash_fn(const char *key, int table_size)
2603 {
2604   unsigned int hashed = 0;
2605   const char *c;
2606   int bits_per_int = sizeof(unsigned int)*8;
2607
2608   for (c = key; *c; c++) {
2609     /* letters have about 5 bits in them */
2610     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2611     hashed ^= *c;
2612   }
2613   return hashed % table_size;
2614 }
2615 #endif
2616
2617 /* Compares A and B.  Returns an integer less than, equal to, or
2618  * greater than zero if A is stored at a memory location that is
2619  * numerical less than, equal to, or greater than that of B.  */
2620 static int
2621 pointercmp(pointer a, pointer b)
2622 {
2623   uintptr_t a_n = (uintptr_t) a;
2624   uintptr_t b_n = (uintptr_t) b;
2625
2626   if (a_n < b_n)
2627     return -1;
2628   if (a_n > b_n)
2629     return 1;
2630   return 0;
2631 }
2632
2633 #ifndef USE_ALIST_ENV
2634
2635 /*
2636  * In this implementation, each frame of the environment may be
2637  * a hash table: a vector of alists hashed by variable name.
2638  * In practice, we use a vector only for the initial frame;
2639  * subsequent frames are too small and transient for the lookup
2640  * speed to out-weigh the cost of making a new vector.
2641  */
2642
2643 static void new_frame_in_env(scheme *sc, pointer old_env)
2644 {
2645   pointer new_frame;
2646
2647   /* The interaction-environment has about 480 variables in it. */
2648   if (old_env == sc->NIL) {
2649     new_frame = mk_vector(sc, 751);
2650   } else {
2651     new_frame = sc->NIL;
2652   }
2653
2654   gc_disable(sc, 1);
2655   sc->envir = immutable_cons(sc, new_frame, old_env);
2656   gc_enable(sc);
2657   setenvironment(sc->envir);
2658 }
2659
2660 /* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
2661  * find_slot_spec_in_env, and no insertion must be done between
2662  * obtaining SSLOT and the call to this function.
2663  *
2664  * If SSLOT is NULL, the new slot is put into the appropriate place in
2665  * the environment vector.  */
2666 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2667                                         pointer variable, pointer value,
2668                                         pointer *sslot)
2669 {
2670 #define new_slot_spec_in_env_allocates  2
2671   pointer slot;
2672   gc_disable(sc, gc_reservations (new_slot_spec_in_env));
2673   slot = immutable_cons(sc, variable, value);
2674
2675   if (sslot == NULL) {
2676     int location;
2677     assert(is_vector(car(env)));
2678     location = hash_fn(symname(variable), vector_length(car(env)));
2679
2680     set_vector_elem(car(env), location,
2681                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2682   } else {
2683     *sslot = immutable_cons(sc, slot, *sslot);
2684   }
2685   gc_enable(sc);
2686 }
2687
2688 /* Find the slot in ENV under the key HDL.  If ALL is given, look in
2689  * all environments enclosing ENV.  If the lookup fails, and SSLOT is
2690  * given, the position where the new slot has to be inserted is stored
2691  * at SSLOT.
2692  *
2693  * SSLOT may be set to NULL if the new symbol should be placed at the
2694  * appropriate place in the vector.  */
2695 static pointer
2696 find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
2697 {
2698   pointer x,y;
2699   int location;
2700   pointer *sl;
2701   int d;
2702   assert(is_symbol(hdl));
2703
2704   for (x = env; x != sc->NIL; x = cdr(x)) {
2705     if (is_vector(car(x))) {
2706       location = hash_fn(symname(hdl), vector_length(car(x)));
2707       sl = NULL;
2708       y = vector_elem(car(x), location);
2709     } else {
2710       sl = &car(x);
2711       y = *sl;
2712     }
2713     for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) {
2714       d = pointercmp(caar(y), hdl);
2715       if (d == 0)
2716         return car(y);          /* Hit.  */
2717       else if (d > 0)
2718         break;                  /* Miss.  */
2719     }
2720
2721     if (x == env && sslot)
2722       *sslot = sl;              /* Insert here.  */
2723
2724     if (!all)
2725       return sc->NIL;           /* Miss, and stop looking.  */
2726   }
2727
2728   return sc->NIL;               /* Not found in any environment.  */
2729 }
2730
2731 #else /* USE_ALIST_ENV */
2732
2733 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2734 {
2735   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2736   setenvironment(sc->envir);
2737 }
2738
2739 /* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
2740  * find_slot_spec_in_env, and no insertion must be done between
2741  * obtaining SSLOT and the call to this function.  */
2742 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2743                                         pointer variable, pointer value,
2744                                         pointer *sslot)
2745 {
2746 #define new_slot_spec_in_env_allocates  2
2747   (void) env;
2748   assert(is_symbol(variable));
2749   *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot);
2750 }
2751
2752 /* Find the slot in ENV under the key HDL.  If ALL is given, look in
2753  * all environments enclosing ENV.  If the lookup fails, and SSLOT is
2754  * given, the position where the new slot has to be inserted is stored
2755  * at SSLOT.  */
2756 static pointer
2757 find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
2758 {
2759     pointer x,y;
2760     pointer *sl;
2761     int d;
2762     assert(is_symbol(hdl));
2763
2764     for (x = env; x != sc->NIL; x = cdr(x)) {
2765       for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) {
2766         d = pointercmp(caar(y), hdl);
2767         if (d == 0)
2768           return car(y);        /* Hit.  */
2769         else if (d > 0)
2770           break;                /* Miss.  */
2771       }
2772
2773       if (x == env && sslot)
2774         *sslot = sl;            /* Insert here.  */
2775
2776       if (!all)
2777         return sc->NIL;         /* Miss, and stop looking.  */
2778     }
2779
2780     return sc->NIL;             /* Not found in any environment.  */
2781 }
2782
2783 #endif /* USE_ALIST_ENV else */
2784
2785 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2786 {
2787   return find_slot_spec_in_env(sc, env, hdl, all, NULL);
2788 }
2789
2790 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2791 {
2792 #define new_slot_in_env_allocates       new_slot_spec_in_env_allocates
2793   pointer slot;
2794   pointer *sslot;
2795   assert(is_symbol(variable));
2796   slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
2797   assert(slot == sc->NIL);
2798   new_slot_spec_in_env(sc, sc->envir, variable, value, sslot);
2799 }
2800
2801 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2802 {
2803   (void)sc;
2804   cdr(slot) = value;
2805 }
2806
2807 static INLINE pointer slot_value_in_env(pointer slot)
2808 {
2809   return cdr(slot);
2810 }
2811
2812 /* ========== Evaluation Cycle ========== */
2813
2814
2815 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2816      const char *str = s;
2817      pointer history;
2818 #if USE_ERROR_HOOK
2819      pointer x;
2820      pointer hdl=sc->ERROR_HOOK;
2821 #endif
2822
2823 #if SHOW_ERROR_LINE
2824      char sbuf[STRBUFFSIZE];
2825 #endif
2826
2827      history = history_flatten(sc);
2828
2829 #if SHOW_ERROR_LINE
2830      /* make sure error is not in REPL */
2831      if (sc->load_stack[sc->file_i].kind & port_file &&
2832          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2833        pointer tag;
2834        const char *fname;
2835        int ln;
2836
2837        if (history != sc->NIL && has_tag(car(history))
2838            && (tag = get_tag(sc, car(history)))
2839            && is_string(car(tag)) && is_integer(cdr(tag))) {
2840          fname = string_value(car(tag));
2841          ln = ivalue_unchecked(cdr(tag));
2842        } else {
2843          fname = string_value(sc->load_stack[sc->file_i].rep.stdio.filename);
2844          ln = ivalue_unchecked(sc->load_stack[sc->file_i].rep.stdio.curr_line);
2845        }
2846
2847        /* should never happen */
2848        if(!fname) fname = "<unknown>";
2849
2850        /* we started from 0 */
2851        ln++;
2852        snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
2853
2854        str = (const char*)sbuf;
2855      }
2856 #endif
2857
2858 #if USE_ERROR_HOOK
2859      x=find_slot_in_env(sc,sc->envir,hdl,1);
2860     if (x != sc->NIL) {
2861          sc->code = cons(sc, cons(sc, sc->QUOTE,
2862                                   cons(sc, history, sc->NIL)),
2863                          sc->NIL);
2864          if(a!=0) {
2865            sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
2866                            sc->code);
2867          } else {
2868            sc->code = cons(sc, sc->F, sc->code);
2869          }
2870          sc->code = cons(sc, mk_string(sc, str), sc->code);
2871          setimmutable(car(sc->code));
2872          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2873          sc->op = (int)OP_EVAL;
2874          return sc->T;
2875     }
2876 #endif
2877
2878     if(a!=0) {
2879           sc->args = cons(sc, (a), sc->NIL);
2880     } else {
2881           sc->args = sc->NIL;
2882     }
2883     sc->args = cons(sc, mk_string(sc, str), sc->args);
2884     setimmutable(car(sc->args));
2885     sc->op = (int)OP_ERR0;
2886     return sc->T;
2887 }
2888 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2889 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2890
2891 /* Too small to turn into function */
2892 # define  BEGIN     do {
2893 # define  END  } while (0)
2894
2895 \f
2896
2897 /* Flags.  The interpreter has a flags field.  When the interpreter
2898  * pushes a frame to the dump stack, it is encoded with the opcode.
2899  * Therefore, we do not use the least significant byte.  */
2900
2901 /* Masks used to encode and decode opcode and flags.  */
2902 #define S_OP_MASK       0x000000ff
2903 #define S_FLAG_MASK     0xffffff00
2904
2905 /* Set if the interpreter evaluates an expression in a tail context
2906  * (see R5RS, section 3.5).  If a function, procedure, or continuation
2907  * is invoked while this flag is set, the call is recorded as tail
2908  * call in the history buffer.  */
2909 #define S_FLAG_TAIL_CONTEXT     0x00000100
2910
2911 /* Set flag F.  */
2912 #define s_set_flag(sc, f)                       \
2913            BEGIN                                \
2914            (sc)->flags |= S_FLAG_ ## f;         \
2915            END
2916
2917 /* Clear flag F.  */
2918 #define s_clear_flag(sc, f)                     \
2919            BEGIN                                \
2920            (sc)->flags &= ~ S_FLAG_ ## f;       \
2921            END
2922
2923 /* Check if flag F is set.  */
2924 #define s_get_flag(sc, f)                       \
2925            !!((sc)->flags & S_FLAG_ ## f)
2926
2927 \f
2928
2929 /* Bounce back to Eval_Cycle and execute A.  */
2930 #define s_goto(sc,a) BEGIN                                  \
2931     sc->op = (int)(a);                                      \
2932     return sc->T; END
2933
2934 #if USE_THREADED_CODE
2935
2936 /* Do not bounce back to Eval_Cycle but execute A by jumping directly
2937  * to it.  Only applicable if A is part of the same dispatch
2938  * function.  */
2939 #define s_thread_to(sc, a)      \
2940      BEGIN                      \
2941      op = (int) (a);            \
2942      goto a;                    \
2943      END
2944
2945 /* Define a label OP and emit a case statement for OP.  For use in the
2946  * dispatch functions.  The slightly peculiar goto that is never
2947  * executed avoids warnings about unused labels.  */
2948 #define CASE(OP)        if (0) goto OP; OP: case OP
2949
2950 #else   /* USE_THREADED_CODE */
2951 #define s_thread_to(sc, a)      s_goto(sc, a)
2952 #define CASE(OP)                case OP
2953 #endif  /* USE_THREADED_CODE */
2954
2955 /* Return to the previous frame on the dump stack, setting the current
2956  * value to A.  */
2957 #define s_return(sc, a) return _s_return(sc, a, 0)
2958
2959 /* Return to the previous frame on the dump stack, setting the current
2960  * value to A, and re-enable the garbage collector.  */
2961 #define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
2962
2963 static INLINE void dump_stack_reset(scheme *sc)
2964 {
2965   sc->dump = sc->NIL;
2966 }
2967
2968 static INLINE void dump_stack_initialize(scheme *sc)
2969 {
2970   dump_stack_reset(sc);
2971 }
2972
2973 static void dump_stack_free(scheme *sc)
2974 {
2975   sc->dump = sc->NIL;
2976 }
2977
2978 static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
2979   pointer dump = sc->dump;
2980   pointer op;
2981   unsigned long v;
2982   sc->value = (a);
2983   if (enable_gc)
2984        gc_enable(sc);
2985   if (dump == sc->NIL)
2986     return sc->NIL;
2987   free_cons(sc, dump, &op, &dump);
2988   v = (unsigned long) ivalue_unchecked(op);
2989   sc->op = (int) (v & S_OP_MASK);
2990   sc->flags = v & S_FLAG_MASK;
2991 #ifdef USE_SMALL_INTEGERS
2992   if (v < MAX_SMALL_INTEGER) {
2993     /* This is a small integer, we must not free it.  */
2994   } else
2995     /* Normal integer.  Recover the cell.  */
2996 #endif
2997     free_cell(sc, op);
2998   free_cons(sc, dump, &sc->args, &dump);
2999   free_cons(sc, dump, &sc->envir, &dump);
3000   free_cons(sc, dump, &sc->code, &sc->dump);
3001   return sc->T;
3002 }
3003
3004 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
3005 #define s_save_allocates        5
3006     pointer dump;
3007     unsigned long v = sc->flags | ((unsigned long) op);
3008     gc_disable(sc, gc_reservations (s_save));
3009     dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
3010     dump = cons(sc, (args), dump);
3011     sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
3012     gc_enable(sc);
3013 }
3014
3015 static INLINE void dump_stack_mark(scheme *sc)
3016 {
3017   mark(sc->dump);
3018 }
3019
3020 \f
3021
3022 #if USE_HISTORY
3023
3024 static void
3025 history_free(scheme *sc)
3026 {
3027   sc->free(sc->history.m);
3028   sc->history.tailstacks = sc->NIL;
3029   sc->history.callstack = sc->NIL;
3030 }
3031
3032 static pointer
3033 history_init(scheme *sc, size_t N, size_t M)
3034 {
3035   size_t i;
3036   struct history *h = &sc->history;
3037
3038   h->N = N;
3039   h->mask_N = N - 1;
3040   h->n = N - 1;
3041   assert ((N & h->mask_N) == 0);
3042
3043   h->M = M;
3044   h->mask_M = M - 1;
3045   assert ((M & h->mask_M) == 0);
3046
3047   h->callstack = mk_vector(sc, N);
3048   if (h->callstack == sc->sink)
3049     goto fail;
3050
3051   h->tailstacks = mk_vector(sc, N);
3052   for (i = 0; i < N; i++) {
3053     pointer tailstack = mk_vector(sc, M);
3054     if (tailstack == sc->sink)
3055       goto fail;
3056     set_vector_elem(h->tailstacks, i, tailstack);
3057   }
3058
3059   h->m = sc->malloc(N * sizeof *h->m);
3060   if (h->m == NULL)
3061     goto fail;
3062
3063   for (i = 0; i < N; i++)
3064     h->m[i] = 0;
3065
3066   return sc->T;
3067
3068 fail:
3069   history_free(sc);
3070   return sc->F;
3071 }
3072
3073 static void
3074 history_mark(scheme *sc)
3075 {
3076   struct history *h = &sc->history;
3077   mark(h->callstack);
3078   mark(h->tailstacks);
3079 }
3080
3081 #define add_mod(a, b, mask)     (((a) + (b)) & (mask))
3082 #define sub_mod(a, b, mask)     add_mod(a, (mask) + 1 - (b), mask)
3083
3084 static INLINE void
3085 tailstack_clear(scheme *sc, pointer v)
3086 {
3087   assert(is_vector(v));
3088   /* XXX optimize */
3089   fill_vector(v, sc->NIL);
3090 }
3091
3092 static pointer
3093 callstack_pop(scheme *sc)
3094 {
3095   struct history *h = &sc->history;
3096   size_t n = h->n;
3097   pointer item;
3098
3099   if (h->callstack == sc->NIL)
3100     return sc->NIL;
3101
3102   item = vector_elem(h->callstack, n);
3103   /* Clear our frame so that it can be gc'ed and we don't run into it
3104    * when walking the history.  */
3105   set_vector_elem(h->callstack, n, sc->NIL);
3106   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3107
3108   /* Exit from the frame.  */
3109   h->n = sub_mod(h->n, 1, h->mask_N);
3110
3111   return item;
3112 }
3113
3114 static void
3115 callstack_push(scheme *sc, pointer item)
3116 {
3117   struct history *h = &sc->history;
3118   size_t n = h->n;
3119
3120   if (h->callstack == sc->NIL)
3121     return;
3122
3123   /* Enter a new frame.  */
3124   n = h->n = add_mod(n, 1, h->mask_N);
3125
3126   /* Initialize tail stack.  */
3127   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3128   h->m[n] = h->mask_M;
3129
3130   set_vector_elem(h->callstack, n, item);
3131 }
3132
3133 static void
3134 tailstack_push(scheme *sc, pointer item)
3135 {
3136   struct history *h = &sc->history;
3137   size_t n = h->n;
3138   size_t m = h->m[n];
3139
3140   if (h->callstack == sc->NIL)
3141     return;
3142
3143   /* Enter a new tail frame.  */
3144   m = h->m[n] = add_mod(m, 1, h->mask_M);
3145   set_vector_elem(vector_elem(h->tailstacks, n), m, item);
3146 }
3147
3148 static pointer
3149 tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
3150                   pointer acc)
3151 {
3152   struct history *h = &sc->history;
3153   pointer frame;
3154
3155   assert(i <= h->M);
3156   assert(n < h->M);
3157
3158   if (acc == sc->sink)
3159     return sc->sink;
3160
3161   if (i == 0) {
3162     /* We reached the end, but we did not see a unused frame.  Signal
3163        this using '... .  */
3164     return cons(sc, mk_symbol(sc, "..."), acc);
3165   }
3166
3167   frame = vector_elem(tailstack, n);
3168   if (frame == sc->NIL) {
3169     /* A unused frame.  We reached the end of the history.  */
3170     return acc;
3171   }
3172
3173   /* Add us.  */
3174   acc = cons(sc, frame, acc);
3175
3176   return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
3177                            acc);
3178 }
3179
3180 static pointer
3181 callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
3182 {
3183   struct history *h = &sc->history;
3184   pointer frame;
3185
3186   assert(i <= h->N);
3187   assert(n < h->N);
3188
3189   if (acc == sc->sink)
3190     return sc->sink;
3191
3192   if (i == 0) {
3193     /* We reached the end, but we did not see a unused frame.  Signal
3194        this using '... .  */
3195     return cons(sc, mk_symbol(sc, "..."), acc);
3196   }
3197
3198   frame = vector_elem(h->callstack, n);
3199   if (frame == sc->NIL) {
3200     /* A unused frame.  We reached the end of the history.  */
3201     return acc;
3202   }
3203
3204   /* First, emit the tail calls.  */
3205   acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
3206                           acc);
3207
3208   /* Then us.  */
3209   acc = cons(sc, frame, acc);
3210
3211   return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
3212 }
3213
3214 static pointer
3215 history_flatten(scheme *sc)
3216 {
3217   struct history *h = &sc->history;
3218   pointer history;
3219
3220   if (h->callstack == sc->NIL)
3221     return sc->NIL;
3222
3223   history = callstack_flatten(sc, h->N, h->n, sc->NIL);
3224   if (history == sc->sink)
3225     return sc->sink;
3226
3227   return reverse_in_place(sc, sc->NIL, history);
3228 }
3229
3230 #undef add_mod
3231 #undef sub_mod
3232
3233 #else   /* USE_HISTORY */
3234
3235 #define history_init(SC, A, B)  (void) 0
3236 #define history_free(SC)        (void) 0
3237 #define callstack_pop(SC)       (void) 0
3238 #define callstack_push(SC, X)   (void) 0
3239 #define tailstack_push(SC, X)   (void) 0
3240
3241 #endif  /* USE_HISTORY */
3242
3243 \f
3244
3245 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
3246
3247 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
3248      pointer x, y;
3249      pointer callsite;
3250
3251      switch (op) {
3252      CASE(OP_LOAD):       /* load */
3253           if(file_interactive(sc)) {
3254                fprintf(sc->outport->_object._port->rep.stdio.file,
3255                "Loading %s\n", strvalue(car(sc->args)));
3256           }
3257           if (!file_push(sc, car(sc->args))) {
3258                Error_1(sc,"unable to open", car(sc->args));
3259           }
3260       else
3261         {
3262           sc->args = mk_integer(sc,sc->file_i);
3263           s_thread_to(sc,OP_T0LVL);
3264         }
3265
3266      CASE(OP_T0LVL): /* top level */
3267        /* If we reached the end of file, this loop is done. */
3268        if(sc->loadport->_object._port->kind & port_saw_EOF)
3269      {
3270        if(sc->file_i == 0)
3271          {
3272            sc->args=sc->NIL;
3273            sc->nesting = sc->nesting_stack[0];
3274            s_goto(sc,OP_QUIT);
3275          }
3276        else
3277          {
3278            file_pop(sc);
3279            s_return(sc,sc->value);
3280          }
3281        /* NOTREACHED */
3282      }
3283
3284        /* If interactive, be nice to user. */
3285        if(file_interactive(sc))
3286      {
3287        sc->envir = sc->global_env;
3288        dump_stack_reset(sc);
3289        putstr(sc,"\n");
3290        putstr(sc,prompt);
3291      }
3292
3293        /* Set up another iteration of REPL */
3294        sc->nesting=0;
3295        sc->save_inport=sc->inport;
3296        sc->inport = sc->loadport;
3297        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
3298        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
3299        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
3300        s_thread_to(sc,OP_READ_INTERNAL);
3301
3302      CASE(OP_T1LVL): /* top level */
3303           sc->code = sc->value;
3304           sc->inport=sc->save_inport;
3305           s_thread_to(sc,OP_EVAL);
3306
3307      CASE(OP_READ_INTERNAL):       /* internal read */
3308           sc->tok = token(sc);
3309           if(sc->tok==TOK_EOF)
3310         { s_return(sc,sc->EOF_OBJ); }
3311           s_goto(sc,OP_RDSEXPR);
3312
3313      CASE(OP_GENSYM):
3314           s_return(sc, gensym(sc));
3315
3316      CASE(OP_VALUEPRINT): /* print evaluation result */
3317           /* OP_VALUEPRINT is always pushed, because when changing from
3318              non-interactive to interactive mode, it needs to be
3319              already on the stack */
3320        if(sc->tracing) {
3321          putstr(sc,"\nGives: ");
3322        }
3323        if(file_interactive(sc)) {
3324          sc->print_flag = 1;
3325          sc->args = sc->value;
3326          s_goto(sc,OP_P0LIST);
3327        } else {
3328          s_return(sc,sc->value);
3329        }
3330
3331      CASE(OP_EVAL):       /* main part of evaluation */
3332 #if USE_TRACING
3333        if(sc->tracing) {
3334          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
3335          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
3336          sc->args=sc->code;
3337          putstr(sc,"\nEval: ");
3338          s_goto(sc,OP_P0LIST);
3339        }
3340        /* fall through */
3341      CASE(OP_REAL_EVAL):
3342 #endif
3343           if (is_symbol(sc->code)) {    /* symbol */
3344                x=find_slot_in_env(sc,sc->envir,sc->code,1);
3345                if (x != sc->NIL) {
3346                     s_return(sc,slot_value_in_env(x));
3347                } else {
3348                     Error_1(sc,"eval: unbound variable:", sc->code);
3349                }
3350           } else if (is_pair(sc->code)) {
3351                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
3352                     sc->code = cdr(sc->code);
3353                     s_goto(sc,syntaxnum(x));
3354                } else {/* first, eval top element and eval arguments */
3355                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
3356                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
3357                     sc->code = car(sc->code);
3358                     s_clear_flag(sc, TAIL_CONTEXT);
3359                     s_thread_to(sc,OP_EVAL);
3360                }
3361           } else {
3362                s_return(sc,sc->code);
3363           }
3364
3365      CASE(OP_E0ARGS):     /* eval arguments */
3366           if (is_macro(sc->value)) {    /* macro expansion */
3367                gc_disable(sc, 1 + gc_reservations (s_save));
3368                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
3369                sc->args = cons(sc,sc->code, sc->NIL);
3370                gc_enable(sc);
3371                sc->code = sc->value;
3372                s_clear_flag(sc, TAIL_CONTEXT);
3373                s_thread_to(sc,OP_APPLY);
3374           } else {
3375                gc_disable(sc, 1);
3376                sc->args = cons(sc, sc->code, sc->NIL);
3377                gc_enable(sc);
3378                sc->code = cdr(sc->code);
3379                s_thread_to(sc,OP_E1ARGS);
3380           }
3381
3382      CASE(OP_E1ARGS):     /* eval arguments */
3383           gc_disable(sc, 1);
3384           sc->args = cons(sc, sc->value, sc->args);
3385           gc_enable(sc);
3386           if (is_pair(sc->code)) { /* continue */
3387                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
3388                sc->code = car(sc->code);
3389                sc->args = sc->NIL;
3390                s_clear_flag(sc, TAIL_CONTEXT);
3391                s_thread_to(sc,OP_EVAL);
3392           } else {  /* end */
3393                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3394                s_thread_to(sc,OP_APPLY_CODE);
3395           }
3396
3397 #if USE_TRACING
3398      CASE(OP_TRACING): {
3399        int tr=sc->tracing;
3400        sc->tracing=ivalue(car(sc->args));
3401        gc_disable(sc, 1);
3402        s_return_enable_gc(sc, mk_integer(sc, tr));
3403      }
3404 #endif
3405
3406 #if USE_HISTORY
3407      CASE(OP_CALLSTACK_POP):      /* pop the call stack */
3408           callstack_pop(sc);
3409           s_return(sc, sc->value);
3410 #endif
3411
3412      CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
3413                            * record in the history as invoked from
3414                            * 'car(args)' */
3415           free_cons(sc, sc->args, &callsite, &sc->args);
3416           sc->code = car(sc->args);
3417           sc->args = cdr(sc->args);
3418           /* Fallthrough.  */
3419
3420      CASE(OP_APPLY):      /* apply 'code' to 'args' */
3421 #if USE_TRACING
3422        if(sc->tracing) {
3423          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
3424          sc->print_flag = 1;
3425          /*  sc->args=cons(sc,sc->code,sc->args);*/
3426          putstr(sc,"\nApply to: ");
3427          s_goto(sc,OP_P0LIST);
3428        }
3429        /* fall through */
3430      CASE(OP_REAL_APPLY):
3431 #endif
3432 #if USE_HISTORY
3433           if (op != OP_APPLY_CODE)
3434             callsite = sc->code;
3435           if (s_get_flag(sc, TAIL_CONTEXT)) {
3436             /* We are evaluating a tail call.  */
3437             tailstack_push(sc, callsite);
3438           } else {
3439             callstack_push(sc, callsite);
3440             s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
3441           }
3442 #endif
3443
3444           if (is_proc(sc->code)) {
3445                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
3446           } else if (is_foreign(sc->code))
3447             {
3448               /* Keep nested calls from GC'ing the arglist */
3449               push_recent_alloc(sc,sc->args,sc->NIL);
3450                x=sc->code->_object._ff(sc,sc->args);
3451                s_return(sc,x);
3452           } else if (is_closure(sc->code) || is_macro(sc->code)
3453              || is_promise(sc->code)) { /* CLOSURE */
3454         /* Should not accept promise */
3455                /* make environment */
3456                new_frame_in_env(sc, closure_env(sc->code));
3457                for (x = car(closure_code(sc->code)), y = sc->args;
3458                     is_pair(x); x = cdr(x), y = cdr(y)) {
3459                     if (y == sc->NIL) {
3460                          Error_1(sc, "not enough arguments, missing:", x);
3461                     } else {
3462                          new_slot_in_env(sc, car(x), car(y));
3463                     }
3464                }
3465                if (x == sc->NIL) {
3466                     if (y != sc->NIL) {
3467                       Error_0(sc, "too many arguments");
3468                     }
3469                } else if (is_symbol(x))
3470                     new_slot_in_env(sc, x, y);
3471                else {
3472                     Error_1(sc,"syntax error in closure: not a symbol:", x);
3473                }
3474                sc->code = cdr(closure_code(sc->code));
3475                sc->args = sc->NIL;
3476                s_set_flag(sc, TAIL_CONTEXT);
3477                s_thread_to(sc,OP_BEGIN);
3478           } else if (is_continuation(sc->code)) { /* CONTINUATION */
3479                sc->dump = cont_dump(sc->code);
3480                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
3481           } else {
3482                Error_1(sc,"illegal function",sc->code);
3483           }
3484
3485      CASE(OP_DOMACRO):    /* do macro */
3486           sc->code = sc->value;
3487           s_thread_to(sc,OP_EVAL);
3488
3489 #if USE_COMPILE_HOOK
3490      CASE(OP_LAMBDA):     /* lambda */
3491           /* If the hook is defined, apply it to sc->code, otherwise
3492              set sc->value fall through */
3493           {
3494                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
3495                if(f==sc->NIL) {
3496                     sc->value = sc->code;
3497                     /* Fallthru */
3498                } else {
3499                     gc_disable(sc, 1 + gc_reservations (s_save));
3500                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
3501                     sc->args=cons(sc,sc->code,sc->NIL);
3502                     gc_enable(sc);
3503                     sc->code=slot_value_in_env(f);
3504                     s_thread_to(sc,OP_APPLY);
3505                }
3506           }
3507
3508 #else
3509      CASE(OP_LAMBDA):     /* lambda */
3510           sc->value = sc->code;
3511           /* Fallthrough. */
3512 #endif
3513
3514      CASE(OP_LAMBDA1):
3515           gc_disable(sc, 1);
3516           s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
3517
3518
3519      CASE(OP_MKCLOSURE): /* make-closure */
3520        x=car(sc->args);
3521        if(car(x)==sc->LAMBDA) {
3522          x=cdr(x);
3523        }
3524        if(cdr(sc->args)==sc->NIL) {
3525          y=sc->envir;
3526        } else {
3527          y=cadr(sc->args);
3528        }
3529        gc_disable(sc, 1);
3530        s_return_enable_gc(sc, mk_closure(sc, x, y));
3531
3532      CASE(OP_QUOTE):      /* quote */
3533           s_return(sc,car(sc->code));
3534
3535      CASE(OP_DEF0):  /* define */
3536           if(is_immutable(car(sc->code)))
3537             Error_1(sc,"define: unable to alter immutable", car(sc->code));
3538
3539           if (is_pair(car(sc->code))) {
3540                x = caar(sc->code);
3541                gc_disable(sc, 2);
3542                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3543                gc_enable(sc);
3544           } else {
3545                x = car(sc->code);
3546                sc->code = cadr(sc->code);
3547           }
3548           if (!is_symbol(x)) {
3549                Error_0(sc,"variable is not a symbol");
3550           }
3551           s_save(sc,OP_DEF1, sc->NIL, x);
3552           s_thread_to(sc,OP_EVAL);
3553
3554      CASE(OP_DEF1): { /* define */
3555           pointer *sslot;
3556           x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
3557           if (x != sc->NIL) {
3558                set_slot_in_env(sc, x, sc->value);
3559           } else {
3560                new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
3561           }
3562           s_return(sc,sc->code);
3563      }
3564
3565      CASE(OP_DEFP):  /* defined? */
3566           x=sc->envir;
3567           if(cdr(sc->args)!=sc->NIL) {
3568                x=cadr(sc->args);
3569           }
3570           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3571
3572      CASE(OP_SET0):       /* set! */
3573           if(is_immutable(car(sc->code)))
3574                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3575           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3576           sc->code = cadr(sc->code);
3577           s_thread_to(sc,OP_EVAL);
3578
3579      CASE(OP_SET1):       /* set! */
3580           y=find_slot_in_env(sc,sc->envir,sc->code,1);
3581           if (y != sc->NIL) {
3582                set_slot_in_env(sc, y, sc->value);
3583                s_return(sc,sc->value);
3584           } else {
3585                Error_1(sc,"set!: unbound variable:", sc->code);
3586           }
3587
3588
3589      CASE(OP_BEGIN):      /* begin */
3590           {
3591             int last;
3592
3593             if (!is_pair(sc->code)) {
3594               s_return(sc,sc->code);
3595             }
3596
3597             last = cdr(sc->code) == sc->NIL;
3598             if (!last) {
3599               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3600             }
3601             sc->code = car(sc->code);
3602             if (! last)
3603               /* This is not the end of the list.  This is not a tail
3604                * position.  */
3605               s_clear_flag(sc, TAIL_CONTEXT);
3606             s_thread_to(sc,OP_EVAL);
3607           }
3608
3609      CASE(OP_IF0):        /* if */
3610           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3611           sc->code = car(sc->code);
3612           s_clear_flag(sc, TAIL_CONTEXT);
3613           s_thread_to(sc,OP_EVAL);
3614
3615      CASE(OP_IF1):        /* if */
3616           if (is_true(sc->value))
3617                sc->code = car(sc->code);
3618           else
3619                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
3620                                             * car(sc->NIL) = sc->NIL */
3621           s_thread_to(sc,OP_EVAL);
3622
3623      CASE(OP_LET0):       /* let */
3624           sc->args = sc->NIL;
3625           sc->value = sc->code;
3626           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3627           s_thread_to(sc,OP_LET1);
3628
3629      CASE(OP_LET1):       /* let (calculate parameters) */
3630           gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3631           sc->args = cons(sc, sc->value, sc->args);