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