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