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