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