146b9e6795c56749b730f14f6b8b074097d307c7
[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 static INLINE void ok_to_freely_gc(scheme *sc)
809 {
810   pointer a = car(sc->sink), next;
811   car(sc->sink) = sc->NIL;
812   while (a != sc->NIL)
813     {
814       next = cdr(a);
815       free_cell(sc, a);
816       a = next;
817     }
818 }
819
820 static pointer get_cell(scheme *sc, pointer a, pointer b)
821 {
822   pointer cell   = get_cell_x(sc, a, b);
823   /* For right now, include "a" and "b" in "cell" so that gc doesn't
824      think they are garbage. */
825   /* Tentatively record it as a pair so gc understands it. */
826   typeflag(cell) = T_PAIR;
827   car(cell) = a;
828   cdr(cell) = b;
829   push_recent_alloc(sc, cell, sc->NIL);
830   return cell;
831 }
832
833 static pointer get_vector_object(scheme *sc, int len, pointer init)
834 {
835   pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
836   if(sc->no_memory) { return sc->sink; }
837   /* Record it as a vector so that gc understands it. */
838   typeflag(cells) = (T_VECTOR | T_ATOM);
839   ivalue_unchecked(cells)=len;
840   set_num_integer(cells);
841   fill_vector(cells,init);
842   push_recent_alloc(sc, cells, sc->NIL);
843   return cells;
844 }
845
846 #if defined TSGRIND
847 static void check_cell_alloced(pointer p, int expect_alloced)
848 {
849   /* Can't use putstr(sc,str) because callers have no access to
850      sc.  */
851   if(typeflag(p) & !expect_alloced)
852     {
853       fprintf(stderr,"Cell is already allocated!\n");
854     }
855   if(!(typeflag(p)) & expect_alloced)
856     {
857       fprintf(stderr,"Cell is not allocated!\n");
858     }
859
860 }
861 static void check_range_alloced(pointer p, int n, int expect_alloced)
862 {
863   int i;
864   for(i = 0;i<n;i++)
865     { (void)check_cell_alloced(p+i,expect_alloced); }
866 }
867
868 #endif
869
870 /* Medium level cell allocation */
871
872 /* get new cons cell */
873 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
874   pointer x = get_cell(sc,a, b);
875
876   typeflag(x) = T_PAIR;
877   if(immutable) {
878     setimmutable(x);
879   }
880   car(x) = a;
881   cdr(x) = b;
882   return (x);
883 }
884
885 /* ========== oblist implementation  ========== */
886
887 #ifndef USE_OBJECT_LIST
888
889 static int hash_fn(const char *key, int table_size);
890
891 static pointer oblist_initial_value(scheme *sc)
892 {
893   return mk_vector(sc, 461); /* probably should be bigger */
894 }
895
896 /* returns the new symbol */
897 static pointer oblist_add_by_name(scheme *sc, const char *name)
898 {
899   pointer x;
900   int location;
901
902   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
903   typeflag(x) = T_SYMBOL;
904   setimmutable(car(x));
905
906   location = hash_fn(name, ivalue_unchecked(sc->oblist));
907   set_vector_elem(sc->oblist, location,
908                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
909   return x;
910 }
911
912 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
913 {
914   int location;
915   pointer x;
916   char *s;
917
918   location = hash_fn(name, ivalue_unchecked(sc->oblist));
919   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
920     s = symname(car(x));
921     /* case-insensitive, per R5RS section 2. */
922     if(stricmp(name, s) == 0) {
923       return car(x);
924     }
925   }
926   return sc->NIL;
927 }
928
929 static pointer oblist_all_symbols(scheme *sc)
930 {
931   int i;
932   pointer x;
933   pointer ob_list = sc->NIL;
934
935   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
936     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
937       ob_list = cons(sc, x, ob_list);
938     }
939   }
940   return ob_list;
941 }
942
943 #else
944
945 static pointer oblist_initial_value(scheme *sc)
946 {
947   return sc->NIL;
948 }
949
950 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
951 {
952      pointer x;
953      char    *s;
954
955      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
956         s = symname(car(x));
957         /* case-insensitive, per R5RS section 2. */
958         if(stricmp(name, s) == 0) {
959           return car(x);
960         }
961      }
962      return sc->NIL;
963 }
964
965 /* returns the new symbol */
966 static pointer oblist_add_by_name(scheme *sc, const char *name)
967 {
968   pointer x;
969
970   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
971   typeflag(x) = T_SYMBOL;
972   setimmutable(car(x));
973   sc->oblist = immutable_cons(sc, x, sc->oblist);
974   return x;
975 }
976 static pointer oblist_all_symbols(scheme *sc)
977 {
978   return sc->oblist;
979 }
980
981 #endif
982
983 static pointer mk_port(scheme *sc, port *p) {
984   pointer x = get_cell(sc, sc->NIL, sc->NIL);
985
986   typeflag(x) = T_PORT|T_ATOM;
987   x->_object._port=p;
988   return (x);
989 }
990
991 pointer mk_foreign_func(scheme *sc, foreign_func f) {
992   pointer x = get_cell(sc, sc->NIL, sc->NIL);
993
994   typeflag(x) = (T_FOREIGN | T_ATOM);
995   x->_object._ff=f;
996   return (x);
997 }
998
999 pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
1000   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1001
1002   typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM);
1003   x->_object._foreign_object._vtable=vtable;
1004   x->_object._foreign_object._data = data;
1005   return (x);
1006 }
1007
1008 INTERFACE pointer mk_character(scheme *sc, int c) {
1009   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1010
1011   typeflag(x) = (T_CHARACTER | T_ATOM);
1012   ivalue_unchecked(x)= c;
1013   set_num_integer(x);
1014   return (x);
1015 }
1016
1017 /* get number atom (integer) */
1018 INTERFACE pointer mk_integer(scheme *sc, long n) {
1019   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1020
1021   typeflag(x) = (T_NUMBER | T_ATOM);
1022   ivalue_unchecked(x)= n;
1023   set_num_integer(x);
1024   return (x);
1025 }
1026
1027 INTERFACE pointer mk_real(scheme *sc, double n) {
1028   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1029
1030   typeflag(x) = (T_NUMBER | T_ATOM);
1031   rvalue_unchecked(x)= n;
1032   set_num_real(x);
1033   return (x);
1034 }
1035
1036 static pointer mk_number(scheme *sc, num n) {
1037  if(n.is_fixnum) {
1038      return mk_integer(sc,n.value.ivalue);
1039  } else {
1040      return mk_real(sc,n.value.rvalue);
1041  }
1042 }
1043
1044 /* allocate name to string area */
1045 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
1046      char *q;
1047
1048      q=(char*)sc->malloc(len_str+1);
1049      if(q==0) {
1050           sc->no_memory=1;
1051           return sc->strbuff;
1052      }
1053      if(str!=0) {
1054           memcpy (q, str, len_str);
1055           q[len_str]=0;
1056      } else {
1057           memset(q, fill, len_str);
1058           q[len_str]=0;
1059      }
1060      return (q);
1061 }
1062
1063 /* get new string */
1064 INTERFACE pointer mk_string(scheme *sc, const char *str) {
1065      return mk_counted_string(sc,str,strlen(str));
1066 }
1067
1068 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
1069      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1070      typeflag(x) = (T_STRING | T_ATOM);
1071      strvalue(x) = store_string(sc,len,str,0);
1072      strlength(x) = len;
1073      return (x);
1074 }
1075
1076 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
1077      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1078      typeflag(x) = (T_STRING | T_ATOM);
1079      strvalue(x) = store_string(sc,len,0,fill);
1080      strlength(x) = len;
1081      return (x);
1082 }
1083
1084 INTERFACE static pointer mk_vector(scheme *sc, int len)
1085 { return get_vector_object(sc,len,sc->NIL); }
1086
1087 INTERFACE static void fill_vector(pointer vec, pointer obj) {
1088      int i;
1089      int n = ivalue(vec)/2+ivalue(vec)%2;
1090      for(i=0; i < n; i++) {
1091           typeflag(vec+1+i) = T_PAIR;
1092           setimmutable(vec+1+i);
1093           car(vec+1+i)=obj;
1094           cdr(vec+1+i)=obj;
1095      }
1096 }
1097
1098 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1099      int n=ielem/2;
1100      if(ielem%2==0) {
1101           return car(vec+1+n);
1102      } else {
1103           return cdr(vec+1+n);
1104      }
1105 }
1106
1107 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1108      int n=ielem/2;
1109      if(ielem%2==0) {
1110           return car(vec+1+n)=a;
1111      } else {
1112           return cdr(vec+1+n)=a;
1113      }
1114 }
1115
1116 /* get new symbol */
1117 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1118      pointer x;
1119
1120      /* first check oblist */
1121      x = oblist_find_by_name(sc, name);
1122      if (x != sc->NIL) {
1123           return (x);
1124      } else {
1125           x = oblist_add_by_name(sc, name);
1126           return (x);
1127      }
1128 }
1129
1130 INTERFACE pointer gensym(scheme *sc) {
1131      pointer x;
1132      char name[40];
1133
1134      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1135           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1136
1137           /* first check oblist */
1138           x = oblist_find_by_name(sc, name);
1139
1140           if (x != sc->NIL) {
1141                continue;
1142           } else {
1143                x = oblist_add_by_name(sc, name);
1144                return (x);
1145           }
1146      }
1147
1148      return sc->NIL;
1149 }
1150
1151 /* double the size of the string buffer */
1152 static int expand_strbuff(scheme *sc) {
1153   size_t new_size = sc->strbuff_size * 2;
1154   char *new_buffer = sc->malloc(new_size);
1155   if (new_buffer == 0) {
1156     sc->no_memory = 1;
1157     return 1;
1158   }
1159   memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
1160   sc->free(sc->strbuff);
1161   sc->strbuff = new_buffer;
1162   sc->strbuff_size = new_size;
1163   return 0;
1164 }
1165
1166 /* make symbol or number atom from string */
1167 static pointer mk_atom(scheme *sc, char *q) {
1168      char    c, *p;
1169      int has_dec_point=0;
1170      int has_fp_exp = 0;
1171
1172 #if USE_COLON_HOOK
1173      if((p=strstr(q,"::"))!=0) {
1174           *p=0;
1175           return cons(sc, sc->COLON_HOOK,
1176                           cons(sc,
1177                               cons(sc,
1178                                    sc->QUOTE,
1179                                    cons(sc, mk_atom(sc,p+2), sc->NIL)),
1180                               cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
1181      }
1182 #endif
1183
1184      p = q;
1185      c = *p++;
1186      if ((c == '+') || (c == '-')) {
1187        c = *p++;
1188        if (c == '.') {
1189          has_dec_point=1;
1190          c = *p++;
1191        }
1192        if (!isdigit(c)) {
1193          return (mk_symbol(sc, strlwr(q)));
1194        }
1195      } else if (c == '.') {
1196        has_dec_point=1;
1197        c = *p++;
1198        if (!isdigit(c)) {
1199          return (mk_symbol(sc, strlwr(q)));
1200        }
1201      } else if (!isdigit(c)) {
1202        return (mk_symbol(sc, strlwr(q)));
1203      }
1204
1205      for ( ; (c = *p) != 0; ++p) {
1206           if (!isdigit(c)) {
1207                if(c=='.') {
1208                     if(!has_dec_point) {
1209                          has_dec_point=1;
1210                          continue;
1211                     }
1212                }
1213                else if ((c == 'e') || (c == 'E')) {
1214                        if(!has_fp_exp) {
1215                           has_dec_point = 1; /* decimal point illegal
1216                                                 from now on */
1217                           p++;
1218                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1219                              continue;
1220                           }
1221                        }
1222                }
1223                return (mk_symbol(sc, strlwr(q)));
1224           }
1225      }
1226      if(has_dec_point) {
1227           return mk_real(sc,atof(q));
1228      }
1229      return (mk_integer(sc, atol(q)));
1230 }
1231
1232 /* make constant */
1233 static pointer mk_sharp_const(scheme *sc, char *name) {
1234      long    x;
1235      char    tmp[STRBUFFSIZE];
1236
1237      if (!strcmp(name, "t"))
1238           return (sc->T);
1239      else if (!strcmp(name, "f"))
1240           return (sc->F);
1241      else if (*name == 'o') {/* #o (octal) */
1242           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1243           sscanf(tmp, "%lo", (long unsigned *)&x);
1244           return (mk_integer(sc, x));
1245      } else if (*name == 'd') {    /* #d (decimal) */
1246           sscanf(name+1, "%ld", (long int *)&x);
1247           return (mk_integer(sc, x));
1248      } else if (*name == 'x') {    /* #x (hex) */
1249           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
1250           sscanf(tmp, "%lx", (long unsigned *)&x);
1251           return (mk_integer(sc, x));
1252      } else if (*name == 'b') {    /* #b (binary) */
1253           x = binary_decode(name+1);
1254           return (mk_integer(sc, x));
1255      } else if (*name == '\\') { /* #\w (character) */
1256           int c=0;
1257           if(stricmp(name+1,"space")==0) {
1258                c=' ';
1259           } else if(stricmp(name+1,"newline")==0) {
1260                c='\n';
1261           } else if(stricmp(name+1,"return")==0) {
1262                c='\r';
1263           } else if(stricmp(name+1,"tab")==0) {
1264                c='\t';
1265      } else if(name[1]=='x' && name[2]!=0) {
1266           int c1=0;
1267           if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
1268                c=c1;
1269           } else {
1270                return sc->NIL;
1271      }
1272 #if USE_ASCII_NAMES
1273           } else if(is_ascii_name(name+1,&c)) {
1274                /* nothing */
1275 #endif
1276           } else if(name[2]==0) {
1277                c=name[1];
1278           } else {
1279                return sc->NIL;
1280           }
1281           return mk_character(sc,c);
1282      } else
1283           return (sc->NIL);
1284 }
1285
1286 /* ========== garbage collector ========== */
1287
1288 /*--
1289  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1290  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1291  *  for marking.
1292  */
1293 static void mark(pointer a) {
1294      pointer t, q, p;
1295
1296      t = (pointer) 0;
1297      p = a;
1298 E2:  setmark(p);
1299      if(is_vector(p)) {
1300           int i;
1301           int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1302           for(i=0; i < n; i++) {
1303                /* Vector cells will be treated like ordinary cells */
1304                mark(p+1+i);
1305           }
1306      }
1307      if (is_atom(p))
1308           goto E6;
1309      /* E4: down car */
1310      q = car(p);
1311      if (q && !is_mark(q)) {
1312           setatom(p);  /* a note that we have moved car */
1313           car(p) = t;
1314           t = p;
1315           p = q;
1316           goto E2;
1317      }
1318 E5:  q = cdr(p); /* down cdr */
1319      if (q && !is_mark(q)) {
1320           cdr(p) = t;
1321           t = p;
1322           p = q;
1323           goto E2;
1324      }
1325 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1326      if (!t)
1327           return;
1328      q = t;
1329      if (is_atom(q)) {
1330           clratom(q);
1331           t = car(q);
1332           car(q) = p;
1333           p = q;
1334           goto E5;
1335      } else {
1336           t = cdr(q);
1337           cdr(q) = p;
1338           p = q;
1339           goto E6;
1340      }
1341 }
1342
1343 /* garbage collection. parameter a, b is marked. */
1344 static void gc(scheme *sc, pointer a, pointer b) {
1345   pointer p;
1346   int i;
1347
1348   if(sc->gc_verbose) {
1349     putstr(sc, "gc...");
1350   }
1351
1352   /* mark system globals */
1353   mark(sc->oblist);
1354   mark(sc->global_env);
1355
1356   /* mark current registers */
1357   mark(sc->args);
1358   mark(sc->envir);
1359   mark(sc->code);
1360   dump_stack_mark(sc);
1361   mark(sc->value);
1362   mark(sc->inport);
1363   mark(sc->save_inport);
1364   mark(sc->outport);
1365   mark(sc->loadport);
1366
1367   /* Mark recent objects the interpreter doesn't know about yet. */
1368   mark(car(sc->sink));
1369   /* Mark any older stuff above nested C calls */
1370   mark(sc->c_nest);
1371
1372   /* mark variables a, b */
1373   mark(a);
1374   mark(b);
1375
1376   /* garbage collect */
1377   clrmark(sc->NIL);
1378   sc->fcells = 0;
1379   sc->free_cell = sc->NIL;
1380   /* free-list is kept sorted by address so as to maintain consecutive
1381      ranges, if possible, for use with vectors. Here we scan the cells
1382      (which are also kept sorted by address) downwards to build the
1383      free-list in sorted order.
1384   */
1385   for (i = sc->last_cell_seg; i >= 0; i--) {
1386     p = sc->cell_seg[i] + CELL_SEGSIZE;
1387     while (--p >= sc->cell_seg[i]) {
1388       if (is_mark(p)) {
1389     clrmark(p);
1390       } else {
1391     /* reclaim cell */
1392         if (typeflag(p) != 0) {
1393           finalize_cell(sc, p);
1394           typeflag(p) = 0;
1395           car(p) = sc->NIL;
1396         }
1397         ++sc->fcells;
1398         cdr(p) = sc->free_cell;
1399         sc->free_cell = p;
1400       }
1401     }
1402   }
1403
1404   if (sc->gc_verbose) {
1405     char msg[80];
1406     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1407     putstr(sc,msg);
1408   }
1409 }
1410
1411 static void finalize_cell(scheme *sc, pointer a) {
1412   if(is_string(a)) {
1413     sc->free(strvalue(a));
1414   } else if(is_port(a)) {
1415     if(a->_object._port->kind&port_file
1416        && a->_object._port->rep.stdio.closeit) {
1417       port_close(sc,a,port_input|port_output);
1418     } else if (a->_object._port->kind & port_srfi6) {
1419       sc->free(a->_object._port->rep.string.start);
1420     }
1421     sc->free(a->_object._port);
1422   } else if(is_foreign_object(a)) {
1423     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1424   }
1425 }
1426
1427 /* ========== Routines for Reading ========== */
1428
1429 static int file_push(scheme *sc, const char *fname) {
1430   FILE *fin = NULL;
1431
1432   if (sc->file_i == MAXFIL-1)
1433      return 0;
1434   fin=fopen(fname,"r");
1435   if(fin!=0) {
1436     sc->file_i++;
1437     sc->load_stack[sc->file_i].kind=port_file|port_input;
1438     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1439     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1440     sc->nesting_stack[sc->file_i]=0;
1441     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1442
1443 #if SHOW_ERROR_LINE
1444     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1445     if(fname)
1446       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1447 #endif
1448   }
1449   return fin!=0;
1450 }
1451
1452 static void file_pop(scheme *sc) {
1453  if(sc->file_i != 0) {
1454    sc->nesting=sc->nesting_stack[sc->file_i];
1455    port_close(sc,sc->loadport,port_input);
1456    sc->file_i--;
1457    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1458  }
1459 }
1460
1461 static int file_interactive(scheme *sc) {
1462  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1463      && sc->inport->_object._port->kind&port_file;
1464 }
1465
1466 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1467   FILE *f;
1468   char *rw;
1469   port *pt;
1470   if(prop==(port_input|port_output)) {
1471     rw="a+";
1472   } else if(prop==port_output) {
1473     rw="w";
1474   } else {
1475     rw="r";
1476   }
1477   f=fopen(fn,rw);
1478   if(f==0) {
1479     return 0;
1480   }
1481   pt=port_rep_from_file(sc,f,prop);
1482   pt->rep.stdio.closeit=1;
1483
1484 #if SHOW_ERROR_LINE
1485   if(fn)
1486     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1487
1488   pt->rep.stdio.curr_line = 0;
1489 #endif
1490   return pt;
1491 }
1492
1493 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1494   port *pt;
1495   pt=port_rep_from_filename(sc,fn,prop);
1496   if(pt==0) {
1497     return sc->NIL;
1498   }
1499   return mk_port(sc,pt);
1500 }
1501
1502 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1503 {
1504     port *pt;
1505
1506     pt = (port *)sc->malloc(sizeof *pt);
1507     if (pt == NULL) {
1508         return NULL;
1509     }
1510     pt->kind = port_file | prop;
1511     pt->rep.stdio.file = f;
1512     pt->rep.stdio.closeit = 0;
1513     return pt;
1514 }
1515
1516 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1517   port *pt;
1518   pt=port_rep_from_file(sc,f,prop);
1519   if(pt==0) {
1520     return sc->NIL;
1521   }
1522   return mk_port(sc,pt);
1523 }
1524
1525 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1526   port *pt;
1527   pt=(port*)sc->malloc(sizeof(port));
1528   if(pt==0) {
1529     return 0;
1530   }
1531   pt->kind=port_string|prop;
1532   pt->rep.string.start=start;
1533   pt->rep.string.curr=start;
1534   pt->rep.string.past_the_end=past_the_end;
1535   return pt;
1536 }
1537
1538 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1539   port *pt;
1540   pt=port_rep_from_string(sc,start,past_the_end,prop);
1541   if(pt==0) {
1542     return sc->NIL;
1543   }
1544   return mk_port(sc,pt);
1545 }
1546
1547 #define BLOCK_SIZE 256
1548
1549 static port *port_rep_from_scratch(scheme *sc) {
1550   port *pt;
1551   char *start;
1552   pt=(port*)sc->malloc(sizeof(port));
1553   if(pt==0) {
1554     return 0;
1555   }
1556   start=sc->malloc(BLOCK_SIZE);
1557   if(start==0) {
1558     return 0;
1559   }
1560   memset(start,' ',BLOCK_SIZE-1);
1561   start[BLOCK_SIZE-1]='\0';
1562   pt->kind=port_string|port_output|port_srfi6;
1563   pt->rep.string.start=start;
1564   pt->rep.string.curr=start;
1565   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1566   return pt;
1567 }
1568
1569 static pointer port_from_scratch(scheme *sc) {
1570   port *pt;
1571   pt=port_rep_from_scratch(sc);
1572   if(pt==0) {
1573     return sc->NIL;
1574   }
1575   return mk_port(sc,pt);
1576 }
1577
1578 static void port_close(scheme *sc, pointer p, int flag) {
1579   port *pt=p->_object._port;
1580   pt->kind&=~flag;
1581   if((pt->kind & (port_input|port_output))==0) {
1582     if(pt->kind&port_file) {
1583
1584 #if SHOW_ERROR_LINE
1585       /* Cleanup is here so (close-*-port) functions could work too */
1586       pt->rep.stdio.curr_line = 0;
1587
1588       if(pt->rep.stdio.filename)
1589         sc->free(pt->rep.stdio.filename);
1590 #endif
1591
1592       fclose(pt->rep.stdio.file);
1593     }
1594     pt->kind=port_free;
1595   }
1596 }
1597
1598 /* get new character from input file */
1599 static int inchar(scheme *sc) {
1600   int c;
1601   port *pt;
1602
1603   pt = sc->inport->_object._port;
1604   if(pt->kind & port_saw_EOF)
1605     { return EOF; }
1606   c = basic_inchar(pt);
1607   if(c == EOF && sc->inport == sc->loadport) {
1608     /* Instead, set port_saw_EOF */
1609     pt->kind |= port_saw_EOF;
1610
1611     /* file_pop(sc); */
1612     return EOF;
1613     /* NOTREACHED */
1614   }
1615   return c;
1616 }
1617
1618 static int basic_inchar(port *pt) {
1619   if(pt->kind & port_file) {
1620     return fgetc(pt->rep.stdio.file);
1621   } else {
1622     if(*pt->rep.string.curr == 0 ||
1623        pt->rep.string.curr == pt->rep.string.past_the_end) {
1624       return EOF;
1625     } else {
1626       return *pt->rep.string.curr++;
1627     }
1628   }
1629 }
1630
1631 /* back character to input buffer */
1632 static void backchar(scheme *sc, int c) {
1633   port *pt;
1634   if(c==EOF) return;
1635   pt=sc->inport->_object._port;
1636   if(pt->kind&port_file) {
1637     ungetc(c,pt->rep.stdio.file);
1638   } else {
1639     if(pt->rep.string.curr!=pt->rep.string.start) {
1640       --pt->rep.string.curr;
1641     }
1642   }
1643 }
1644
1645 static int realloc_port_string(scheme *sc, port *p)
1646 {
1647   char *start=p->rep.string.start;
1648   size_t old_size = p->rep.string.past_the_end - start;
1649   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1650   char *str=sc->malloc(new_size);
1651   if(str) {
1652     memset(str,' ',new_size-1);
1653     str[new_size-1]='\0';
1654     memcpy(str, start, old_size);
1655     p->rep.string.start=str;
1656     p->rep.string.past_the_end=str+new_size-1;
1657     p->rep.string.curr-=start-str;
1658     sc->free(start);
1659     return 1;
1660   } else {
1661     return 0;
1662   }
1663 }
1664
1665 INTERFACE void putstr(scheme *sc, const char *s) {
1666   port *pt=sc->outport->_object._port;
1667   if(pt->kind&port_file) {
1668     fputs(s,pt->rep.stdio.file);
1669   } else {
1670     for(;*s;s++) {
1671       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1672         *pt->rep.string.curr++=*s;
1673       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1674         *pt->rep.string.curr++=*s;
1675       }
1676     }
1677   }
1678 }
1679
1680 static void putchars(scheme *sc, const char *s, int len) {
1681   port *pt=sc->outport->_object._port;
1682   if(pt->kind&port_file) {
1683     fwrite(s,1,len,pt->rep.stdio.file);
1684   } else {
1685     for(;len;len--) {
1686       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1687         *pt->rep.string.curr++=*s++;
1688       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1689         *pt->rep.string.curr++=*s++;
1690       }
1691     }
1692   }
1693 }
1694
1695 INTERFACE void putcharacter(scheme *sc, int c) {
1696   port *pt=sc->outport->_object._port;
1697   if(pt->kind&port_file) {
1698     fputc(c,pt->rep.stdio.file);
1699   } else {
1700     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1701       *pt->rep.string.curr++=c;
1702     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1703         *pt->rep.string.curr++=c;
1704     }
1705   }
1706 }
1707
1708 /* read characters up to delimiter, but cater to character constants */
1709 static char *readstr_upto(scheme *sc, char *delim) {
1710   char *p = sc->strbuff;
1711
1712   while ((p - sc->strbuff < sc->strbuff_size) &&
1713          !is_one_of(delim, (*p++ = inchar(sc))));
1714
1715   if(p == sc->strbuff+2 && p[-2] == '\\') {
1716     *p=0;
1717   } else {
1718     backchar(sc,p[-1]);
1719     *--p = '\0';
1720   }
1721   return sc->strbuff;
1722 }
1723
1724 /* read string expression "xxx...xxx" */
1725 static pointer readstrexp(scheme *sc) {
1726   char *p = sc->strbuff;
1727   int c;
1728   int c1=0;
1729   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1730
1731   for (;;) {
1732     c=inchar(sc);
1733     if(c == EOF) {
1734       return sc->F;
1735     }
1736     if(p-sc->strbuff > (sc->strbuff_size)-1) {
1737       ptrdiff_t offset = p - sc->strbuff;
1738       if (expand_strbuff(sc) != 0) {
1739         return sc->F;
1740       }
1741       p = sc->strbuff + offset;
1742     }
1743     switch(state) {
1744         case st_ok:
1745             switch(c) {
1746                 case '\\':
1747                     state=st_bsl;
1748                     break;
1749                 case '"':
1750                     *p=0;
1751                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1752                 default:
1753                     *p++=c;
1754                     break;
1755             }
1756             break;
1757         case st_bsl:
1758             switch(c) {
1759                 case '0':
1760                 case '1':
1761                 case '2':
1762                 case '3':
1763                 case '4':
1764                 case '5':
1765                 case '6':
1766                 case '7':
1767                         state=st_oct1;
1768                         c1=c-'0';
1769                         break;
1770                 case 'x':
1771                 case 'X':
1772                     state=st_x1;
1773                     c1=0;
1774                     break;
1775                 case 'n':
1776                     *p++='\n';
1777                     state=st_ok;
1778                     break;
1779                 case 't':
1780                     *p++='\t';
1781                     state=st_ok;
1782                     break;
1783                 case 'r':
1784                     *p++='\r';
1785                     state=st_ok;
1786                     break;
1787                 case '"':
1788                     *p++='"';
1789                     state=st_ok;
1790                     break;
1791                 default:
1792                     *p++=c;
1793                     state=st_ok;
1794                     break;
1795             }
1796             break;
1797         case st_x1:
1798         case st_x2:
1799             c=toupper(c);
1800             if(c>='0' && c<='F') {
1801                 if(c<='9') {
1802                     c1=(c1<<4)+c-'0';
1803                 } else {
1804                     c1=(c1<<4)+c-'A'+10;
1805                 }
1806                 if(state==st_x1) {
1807                     state=st_x2;
1808                 } else {
1809                     *p++=c1;
1810                     state=st_ok;
1811                 }
1812             } else {
1813                 return sc->F;
1814             }
1815             break;
1816         case st_oct1:
1817         case st_oct2:
1818             if (c < '0' || c > '7')
1819             {
1820                    *p++=c1;
1821                    backchar(sc, c);
1822                    state=st_ok;
1823             }
1824             else
1825             {
1826                 if (state==st_oct2 && c1 >= 32)
1827                     return sc->F;
1828
1829                    c1=(c1<<3)+(c-'0');
1830
1831                 if (state == st_oct1)
1832                         state=st_oct2;
1833                 else
1834                 {
1835                         *p++=c1;
1836                         state=st_ok;
1837                    }
1838             }
1839             break;
1840
1841     }
1842   }
1843 }
1844
1845 /* check c is in chars */
1846 static INLINE int is_one_of(char *s, int c) {
1847      if(c==EOF) return 1;
1848      while (*s)
1849           if (*s++ == c)
1850                return (1);
1851      return (0);
1852 }
1853
1854 /* skip white characters */
1855 static INLINE int skipspace(scheme *sc) {
1856      int c = 0, curr_line = 0;
1857
1858      do {
1859          c=inchar(sc);
1860 #if SHOW_ERROR_LINE
1861          if(c=='\n')
1862            curr_line++;
1863 #endif
1864      } while (isspace(c));
1865
1866 /* record it */
1867 #if SHOW_ERROR_LINE
1868      if (sc->load_stack[sc->file_i].kind & port_file)
1869        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
1870 #endif
1871
1872      if(c!=EOF) {
1873           backchar(sc,c);
1874       return 1;
1875      }
1876      else
1877        { return EOF; }
1878 }
1879
1880 /* get token */
1881 static int token(scheme *sc) {
1882      int c;
1883      c = skipspace(sc);
1884      if(c == EOF) { return (TOK_EOF); }
1885      switch (c=inchar(sc)) {
1886      case EOF:
1887           return (TOK_EOF);
1888      case '(':
1889           return (TOK_LPAREN);
1890      case ')':
1891           return (TOK_RPAREN);
1892      case '.':
1893           c=inchar(sc);
1894           if(is_one_of(" \n\t",c)) {
1895                return (TOK_DOT);
1896           } else {
1897                backchar(sc,c);
1898                backchar(sc,'.');
1899                return TOK_ATOM;
1900           }
1901      case '\'':
1902           return (TOK_QUOTE);
1903      case ';':
1904            while ((c=inchar(sc)) != '\n' && c!=EOF)
1905              ;
1906
1907 #if SHOW_ERROR_LINE
1908            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1909              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1910 #endif
1911
1912        if(c == EOF)
1913          { return (TOK_EOF); }
1914        else
1915          { return (token(sc));}
1916      case '"':
1917           return (TOK_DQUOTE);
1918      case BACKQUOTE:
1919           return (TOK_BQUOTE);
1920      case ',':
1921          if ((c=inchar(sc)) == '@') {
1922                return (TOK_ATMARK);
1923          } else {
1924                backchar(sc,c);
1925                return (TOK_COMMA);
1926          }
1927      case '#':
1928           c=inchar(sc);
1929           if (c == '(') {
1930                return (TOK_VEC);
1931           } else if(c == '!') {
1932                while ((c=inchar(sc)) != '\n' && c!=EOF)
1933                    ;
1934
1935 #if SHOW_ERROR_LINE
1936            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1937              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1938 #endif
1939
1940            if(c == EOF)
1941              { return (TOK_EOF); }
1942            else
1943              { return (token(sc));}
1944           } else {
1945                backchar(sc,c);
1946                if(is_one_of(" tfodxb\\",c)) {
1947                     return TOK_SHARP_CONST;
1948                } else {
1949                     return (TOK_SHARP);
1950                }
1951           }
1952      default:
1953           backchar(sc,c);
1954           return (TOK_ATOM);
1955      }
1956 }
1957
1958 /* ========== Routines for Printing ========== */
1959 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
1960
1961 static void printslashstring(scheme *sc, char *p, int len) {
1962   int i;
1963   unsigned char *s=(unsigned char*)p;
1964   putcharacter(sc,'"');
1965   for ( i=0; i<len; i++) {
1966     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
1967       putcharacter(sc,'\\');
1968       switch(*s) {
1969       case '"':
1970         putcharacter(sc,'"');
1971         break;
1972       case '\n':
1973         putcharacter(sc,'n');
1974         break;
1975       case '\t':
1976         putcharacter(sc,'t');
1977         break;
1978       case '\r':
1979         putcharacter(sc,'r');
1980         break;
1981       case '\\':
1982         putcharacter(sc,'\\');
1983         break;
1984       default: {
1985           int d=*s/16;
1986           putcharacter(sc,'x');
1987           if(d<10) {
1988             putcharacter(sc,d+'0');
1989           } else {
1990             putcharacter(sc,d-10+'A');
1991           }
1992           d=*s%16;
1993           if(d<10) {
1994             putcharacter(sc,d+'0');
1995           } else {
1996             putcharacter(sc,d-10+'A');
1997           }
1998         }
1999       }
2000     } else {
2001       putcharacter(sc,*s);
2002     }
2003     s++;
2004   }
2005   putcharacter(sc,'"');
2006 }
2007
2008
2009 /* print atoms */
2010 static void printatom(scheme *sc, pointer l, int f) {
2011   char *p;
2012   int len;
2013   atom2str(sc,l,f,&p,&len);
2014   putchars(sc,p,len);
2015 }
2016
2017
2018 /* Uses internal buffer unless string pointer is already available */
2019 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2020      char *p;
2021
2022      if (l == sc->NIL) {
2023           p = "()";
2024      } else if (l == sc->T) {
2025           p = "#t";
2026      } else if (l == sc->F) {
2027           p = "#f";
2028      } else if (l == sc->EOF_OBJ) {
2029           p = "#<EOF>";
2030      } else if (is_port(l)) {
2031           p = "#<PORT>";
2032      } else if (is_number(l)) {
2033           p = sc->strbuff;
2034           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2035               if(num_is_integer(l)) {
2036                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2037               } else {
2038                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2039                    /* r5rs says there must be a '.' (unless 'e'?) */
2040                    f = strcspn(p, ".e");
2041                    if (p[f] == 0) {
2042                         p[f] = '.'; /* not found, so add '.0' at the end */
2043                         p[f+1] = '0';
2044                         p[f+2] = 0;
2045                    }
2046               }
2047           } else {
2048               long v = ivalue(l);
2049               if (f == 16) {
2050                   if (v >= 0)
2051                     snprintf(p, STRBUFFSIZE, "%lx", v);
2052                   else
2053                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2054               } else if (f == 8) {
2055                   if (v >= 0)
2056                     snprintf(p, STRBUFFSIZE, "%lo", v);
2057                   else
2058                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2059               } else if (f == 2) {
2060                   unsigned long b = (v < 0) ? -v : v;
2061                   p = &p[STRBUFFSIZE-1];
2062                   *p = 0;
2063                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2064                   if (v < 0) *--p = '-';
2065               }
2066           }
2067      } else if (is_string(l)) {
2068           if (!f) {
2069                *pp = strvalue(l);
2070                *plen = strlength(l);
2071                return;
2072           } else { /* Hack, uses the fact that printing is needed */
2073                *pp=sc->strbuff;
2074                *plen=0;
2075                printslashstring(sc, strvalue(l), strlength(l));
2076                return;
2077           }
2078      } else if (is_character(l)) {
2079           int c=charvalue(l);
2080           p = sc->strbuff;
2081           if (!f) {
2082                p[0]=c;
2083                p[1]=0;
2084           } else {
2085                switch(c) {
2086                case ' ':
2087                     p = "#\\space";
2088                     break;
2089                case '\n':
2090                     p = "#\\newline";
2091                     break;
2092                case '\r':
2093                     p = "#\\return";
2094                     break;
2095                case '\t':
2096                     p = "#\\tab";
2097                     break;
2098                default:
2099 #if USE_ASCII_NAMES
2100                     if(c==127) {
2101                          p = "#\\del";
2102                          break;
2103                     } else if(c<32) {
2104                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2105                          break;
2106                     }
2107 #else
2108                     if(c<32) {
2109                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2110                       break;
2111                     }
2112 #endif
2113                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2114                     break;
2115                }
2116           }
2117      } else if (is_symbol(l)) {
2118           p = symname(l);
2119      } else if (is_proc(l)) {
2120           p = sc->strbuff;
2121           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2122      } else if (is_macro(l)) {
2123           p = "#<MACRO>";
2124      } else if (is_closure(l)) {
2125           p = "#<CLOSURE>";
2126      } else if (is_promise(l)) {
2127           p = "#<PROMISE>";
2128      } else if (is_foreign(l)) {
2129           p = sc->strbuff;
2130           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2131      } else if (is_continuation(l)) {
2132           p = "#<CONTINUATION>";
2133      } else if (is_foreign_object(l)) {
2134           p = sc->strbuff;
2135           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2136      } else {
2137           p = "#<ERROR>";
2138      }
2139      *pp=p;
2140      *plen=strlen(p);
2141 }
2142 /* ========== Routines for Evaluation Cycle ========== */
2143
2144 /* make closure. c is code. e is environment */
2145 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2146      pointer x = get_cell(sc, c, e);
2147
2148      typeflag(x) = T_CLOSURE;
2149      car(x) = c;
2150      cdr(x) = e;
2151      return (x);
2152 }
2153
2154 /* make continuation. */
2155 static pointer mk_continuation(scheme *sc, pointer d) {
2156      pointer x = get_cell(sc, sc->NIL, d);
2157
2158      typeflag(x) = T_CONTINUATION;
2159      cont_dump(x) = d;
2160      return (x);
2161 }
2162
2163 static pointer list_star(scheme *sc, pointer d) {
2164   pointer p, q;
2165   if(cdr(d)==sc->NIL) {
2166     return car(d);
2167   }
2168   p=cons(sc,car(d),cdr(d));
2169   q=p;
2170   while(cdr(cdr(p))!=sc->NIL) {
2171     d=cons(sc,car(p),cdr(p));
2172     if(cdr(cdr(p))!=sc->NIL) {
2173       p=cdr(d);
2174     }
2175   }
2176   cdr(p)=car(cdr(p));
2177   return q;
2178 }
2179
2180 /* reverse list -- produce new list */
2181 static pointer reverse(scheme *sc, pointer a) {
2182 /* a must be checked by gc */
2183      pointer p = sc->NIL;
2184
2185      for ( ; is_pair(a); a = cdr(a)) {
2186           p = cons(sc, car(a), p);
2187      }
2188      return (p);
2189 }
2190
2191 /* reverse list --- in-place */
2192 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2193      pointer p = list, result = term, q;
2194
2195      while (p != sc->NIL) {
2196           q = cdr(p);
2197           cdr(p) = result;
2198           result = p;
2199           p = q;
2200      }
2201      return (result);
2202 }
2203
2204 /* append list -- produce new list (in reverse order) */
2205 static pointer revappend(scheme *sc, pointer a, pointer b) {
2206     pointer result = a;
2207     pointer p = b;
2208
2209     while (is_pair(p)) {
2210         result = cons(sc, car(p), result);
2211         p = cdr(p);
2212     }
2213
2214     if (p == sc->NIL) {
2215         return result;
2216     }
2217
2218     return sc->F;   /* signal an error */
2219 }
2220
2221 /* equivalence of atoms */
2222 int eqv(pointer a, pointer b) {
2223      if (is_string(a)) {
2224           if (is_string(b))
2225                return (strvalue(a) == strvalue(b));
2226           else
2227                return (0);
2228      } else if (is_number(a)) {
2229           if (is_number(b)) {
2230                if (num_is_integer(a) == num_is_integer(b))
2231                     return num_eq(nvalue(a),nvalue(b));
2232           }
2233           return (0);
2234      } else if (is_character(a)) {
2235           if (is_character(b))
2236                return charvalue(a)==charvalue(b);
2237           else
2238                return (0);
2239      } else if (is_port(a)) {
2240           if (is_port(b))
2241                return a==b;
2242           else
2243                return (0);
2244      } else if (is_proc(a)) {
2245           if (is_proc(b))
2246                return procnum(a)==procnum(b);
2247           else
2248                return (0);
2249      } else {
2250           return (a == b);
2251      }
2252 }
2253
2254 /* true or false value macro */
2255 /* () is #t in R5RS */
2256 #define is_true(p)       ((p) != sc->F)
2257 #define is_false(p)      ((p) == sc->F)
2258
2259 /* ========== Environment implementation  ========== */
2260
2261 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2262
2263 static int hash_fn(const char *key, int table_size)
2264 {
2265   unsigned int hashed = 0;
2266   const char *c;
2267   int bits_per_int = sizeof(unsigned int)*8;
2268
2269   for (c = key; *c; c++) {
2270     /* letters have about 5 bits in them */
2271     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2272     hashed ^= *c;
2273   }
2274   return hashed % table_size;
2275 }
2276 #endif
2277
2278 #ifndef USE_ALIST_ENV
2279
2280 /*
2281  * In this implementation, each frame of the environment may be
2282  * a hash table: a vector of alists hashed by variable name.
2283  * In practice, we use a vector only for the initial frame;
2284  * subsequent frames are too small and transient for the lookup
2285  * speed to out-weigh the cost of making a new vector.
2286  */
2287
2288 static void new_frame_in_env(scheme *sc, pointer old_env)
2289 {
2290   pointer new_frame;
2291
2292   /* The interaction-environment has about 300 variables in it. */
2293   if (old_env == sc->NIL) {
2294     new_frame = mk_vector(sc, 461);
2295   } else {
2296     new_frame = sc->NIL;
2297   }
2298
2299   sc->envir = immutable_cons(sc, new_frame, old_env);
2300   setenvironment(sc->envir);
2301 }
2302
2303 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2304                                         pointer variable, pointer value)
2305 {
2306   pointer slot = immutable_cons(sc, variable, value);
2307
2308   if (is_vector(car(env))) {
2309     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2310
2311     set_vector_elem(car(env), location,
2312                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2313   } else {
2314     car(env) = immutable_cons(sc, slot, car(env));
2315   }
2316 }
2317
2318 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2319 {
2320   pointer x,y;
2321   int location;
2322
2323   for (x = env; x != sc->NIL; x = cdr(x)) {
2324     if (is_vector(car(x))) {
2325       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2326       y = vector_elem(car(x), location);
2327     } else {
2328       y = car(x);
2329     }
2330     for ( ; y != sc->NIL; y = cdr(y)) {
2331               if (caar(y) == hdl) {
2332                    break;
2333               }
2334          }
2335          if (y != sc->NIL) {
2336               break;
2337          }
2338          if(!all) {
2339            return sc->NIL;
2340          }
2341     }
2342     if (x != sc->NIL) {
2343           return car(y);
2344     }
2345     return sc->NIL;
2346 }
2347
2348 #else /* USE_ALIST_ENV */
2349
2350 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2351 {
2352   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2353   setenvironment(sc->envir);
2354 }
2355
2356 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2357                                         pointer variable, pointer value)
2358 {
2359   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2360 }
2361
2362 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2363 {
2364     pointer x,y;
2365     for (x = env; x != sc->NIL; x = cdr(x)) {
2366          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2367               if (caar(y) == hdl) {
2368                    break;
2369               }
2370          }
2371          if (y != sc->NIL) {
2372               break;
2373          }
2374          if(!all) {
2375            return sc->NIL;
2376          }
2377     }
2378     if (x != sc->NIL) {
2379           return car(y);
2380     }
2381     return sc->NIL;
2382 }
2383
2384 #endif /* USE_ALIST_ENV else */
2385
2386 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2387 {
2388   new_slot_spec_in_env(sc, sc->envir, variable, value);
2389 }
2390
2391 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2392 {
2393   (void)sc;
2394   cdr(slot) = value;
2395 }
2396
2397 static INLINE pointer slot_value_in_env(pointer slot)
2398 {
2399   return cdr(slot);
2400 }
2401
2402 /* ========== Evaluation Cycle ========== */
2403
2404
2405 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2406      const char *str = s;
2407 #if USE_ERROR_HOOK
2408      pointer x;
2409      pointer hdl=sc->ERROR_HOOK;
2410 #endif
2411
2412 #if SHOW_ERROR_LINE
2413      char sbuf[STRBUFFSIZE];
2414
2415      /* make sure error is not in REPL */
2416      if (sc->load_stack[sc->file_i].kind & port_file &&
2417          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2418        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2419        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2420
2421        /* should never happen */
2422        if(!fname) fname = "<unknown>";
2423
2424        /* we started from 0 */
2425        ln++;
2426        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2427
2428        str = (const char*)sbuf;
2429      }
2430 #endif
2431
2432 #if USE_ERROR_HOOK
2433      x=find_slot_in_env(sc,sc->envir,hdl,1);
2434     if (x != sc->NIL) {
2435          if(a!=0) {
2436                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2437          } else {
2438                sc->code = sc->NIL;
2439          }
2440          sc->code = cons(sc, mk_string(sc, str), sc->code);
2441          setimmutable(car(sc->code));
2442          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2443          sc->op = (int)OP_EVAL;
2444          return sc->T;
2445     }
2446 #endif
2447
2448     if(a!=0) {
2449           sc->args = cons(sc, (a), sc->NIL);
2450     } else {
2451           sc->args = sc->NIL;
2452     }
2453     sc->args = cons(sc, mk_string(sc, str), sc->args);
2454     setimmutable(car(sc->args));
2455     sc->op = (int)OP_ERR0;
2456     return sc->T;
2457 }
2458 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2459 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2460
2461 /* Too small to turn into function */
2462 # define  BEGIN     do {
2463 # define  END  } while (0)
2464
2465 /* Bounce back to Eval_Cycle and execute A.  */
2466 #define s_goto(sc,a) BEGIN                                  \
2467     sc->op = (int)(a);                                      \
2468     return sc->T; END
2469
2470 #if USE_THREADED_CODE
2471
2472 /* Do not bounce back to Eval_Cycle but execute A by jumping directly
2473  * to it.  Only applicable if A is part of the same dispatch
2474  * function.  */
2475 #define s_thread_to(sc, a)      \
2476      BEGIN                      \
2477      op = (int) (a);            \
2478      goto a;                    \
2479      END
2480
2481 /* Define a label OP and emit a case statement for OP.  For use in the
2482  * dispatch functions.  The slightly peculiar goto that is never
2483  * executed avoids warnings about unused labels.  */
2484 #define CASE(OP)        if (0) goto OP; OP: case OP
2485
2486 #else   /* USE_THREADED_CODE */
2487 #define s_thread_to(sc, a)      s_goto(sc, a)
2488 #define CASE(OP)                case OP
2489 #endif  /* USE_THREADED_CODE */
2490
2491 #define s_return(sc,a) return _s_return(sc,a)
2492
2493 static INLINE void dump_stack_reset(scheme *sc)
2494 {
2495   sc->dump = sc->NIL;
2496 }
2497
2498 static INLINE void dump_stack_initialize(scheme *sc)
2499 {
2500   dump_stack_reset(sc);
2501 }
2502
2503 static void dump_stack_free(scheme *sc)
2504 {
2505   sc->dump = sc->NIL;
2506 }
2507
2508 static pointer _s_return(scheme *sc, pointer a) {
2509   pointer dump = sc->dump;
2510   pointer op;
2511   sc->value = (a);
2512   if (dump == sc->NIL)
2513     return sc->NIL;
2514   free_cons(sc, dump, &op, &dump);
2515   sc->op = ivalue(op);
2516   free_cons(sc, dump, &sc->args, &dump);
2517   free_cons(sc, dump, &sc->envir, &dump);
2518   free_cons(sc, dump, &sc->code, &sc->dump);
2519   return sc->T;
2520 }
2521
2522 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2523     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2524     sc->dump = cons(sc, (args), sc->dump);
2525     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2526 }
2527
2528 static INLINE void dump_stack_mark(scheme *sc)
2529 {
2530   mark(sc->dump);
2531 }
2532
2533 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
2534
2535 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2536      pointer x, y;
2537
2538      switch (op) {
2539      CASE(OP_LOAD):       /* load */
2540           if(file_interactive(sc)) {
2541                fprintf(sc->outport->_object._port->rep.stdio.file,
2542                "Loading %s\n", strvalue(car(sc->args)));
2543           }
2544           if (!file_push(sc,strvalue(car(sc->args)))) {
2545                Error_1(sc,"unable to open", car(sc->args));
2546           }
2547       else
2548         {
2549           sc->args = mk_integer(sc,sc->file_i);
2550           s_thread_to(sc,OP_T0LVL);
2551         }
2552
2553      CASE(OP_T0LVL): /* top level */
2554        /* If we reached the end of file, this loop is done. */
2555        if(sc->loadport->_object._port->kind & port_saw_EOF)
2556      {
2557        if(sc->file_i == 0)
2558          {
2559            sc->args=sc->NIL;
2560            sc->nesting = sc->nesting_stack[0];
2561            s_goto(sc,OP_QUIT);
2562          }
2563        else
2564          {
2565            file_pop(sc);
2566            s_return(sc,sc->value);
2567          }
2568        /* NOTREACHED */
2569      }
2570
2571        /* If interactive, be nice to user. */
2572        if(file_interactive(sc))
2573      {
2574        sc->envir = sc->global_env;
2575        dump_stack_reset(sc);
2576        putstr(sc,"\n");
2577        putstr(sc,prompt);
2578      }
2579
2580        /* Set up another iteration of REPL */
2581        sc->nesting=0;
2582        sc->save_inport=sc->inport;
2583        sc->inport = sc->loadport;
2584        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2585        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2586        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2587        s_thread_to(sc,OP_READ_INTERNAL);
2588
2589      CASE(OP_T1LVL): /* top level */
2590           sc->code = sc->value;
2591           sc->inport=sc->save_inport;
2592           s_thread_to(sc,OP_EVAL);
2593
2594      CASE(OP_READ_INTERNAL):       /* internal read */
2595           sc->tok = token(sc);
2596           if(sc->tok==TOK_EOF)
2597         { s_return(sc,sc->EOF_OBJ); }
2598           s_goto(sc,OP_RDSEXPR);
2599
2600      CASE(OP_GENSYM):
2601           s_return(sc, gensym(sc));
2602
2603      CASE(OP_VALUEPRINT): /* print evaluation result */
2604           /* OP_VALUEPRINT is always pushed, because when changing from
2605              non-interactive to interactive mode, it needs to be
2606              already on the stack */
2607        if(sc->tracing) {
2608          putstr(sc,"\nGives: ");
2609        }
2610        if(file_interactive(sc)) {
2611          sc->print_flag = 1;
2612          sc->args = sc->value;
2613          s_goto(sc,OP_P0LIST);
2614        } else {
2615          s_return(sc,sc->value);
2616        }
2617
2618      CASE(OP_EVAL):       /* main part of evaluation */
2619 #if USE_TRACING
2620        if(sc->tracing) {
2621          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2622          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2623          sc->args=sc->code;
2624          putstr(sc,"\nEval: ");
2625          s_goto(sc,OP_P0LIST);
2626        }
2627        /* fall through */
2628      CASE(OP_REAL_EVAL):
2629 #endif
2630           if (is_symbol(sc->code)) {    /* symbol */
2631                x=find_slot_in_env(sc,sc->envir,sc->code,1);
2632                if (x != sc->NIL) {
2633                     s_return(sc,slot_value_in_env(x));
2634                } else {
2635                     Error_1(sc,"eval: unbound variable:", sc->code);
2636                }
2637           } else if (is_pair(sc->code)) {
2638                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
2639                     sc->code = cdr(sc->code);
2640                     s_goto(sc,syntaxnum(x));
2641                } else {/* first, eval top element and eval arguments */
2642                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2643                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2644                     sc->code = car(sc->code);
2645                     s_thread_to(sc,OP_EVAL);
2646                }
2647           } else {
2648                s_return(sc,sc->code);
2649           }
2650
2651      CASE(OP_E0ARGS):     /* eval arguments */
2652           if (is_macro(sc->value)) {    /* macro expansion */
2653                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2654                sc->args = cons(sc,sc->code, sc->NIL);
2655                sc->code = sc->value;
2656                s_thread_to(sc,OP_APPLY);
2657           } else {
2658                sc->code = cdr(sc->code);
2659                s_thread_to(sc,OP_E1ARGS);
2660           }
2661
2662      CASE(OP_E1ARGS):     /* eval arguments */
2663           sc->args = cons(sc, sc->value, sc->args);
2664           if (is_pair(sc->code)) { /* continue */
2665                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2666                sc->code = car(sc->code);
2667                sc->args = sc->NIL;
2668                s_thread_to(sc,OP_EVAL);
2669           } else {  /* end */
2670                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2671                sc->code = car(sc->args);
2672                sc->args = cdr(sc->args);
2673                s_thread_to(sc,OP_APPLY);
2674           }
2675
2676 #if USE_TRACING
2677      CASE(OP_TRACING): {
2678        int tr=sc->tracing;
2679        sc->tracing=ivalue(car(sc->args));
2680        s_return(sc,mk_integer(sc,tr));
2681      }
2682 #endif
2683
2684      CASE(OP_APPLY):      /* apply 'code' to 'args' */
2685 #if USE_TRACING
2686        if(sc->tracing) {
2687          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2688          sc->print_flag = 1;
2689          /*  sc->args=cons(sc,sc->code,sc->args);*/
2690          putstr(sc,"\nApply to: ");
2691          s_goto(sc,OP_P0LIST);
2692        }
2693        /* fall through */
2694      CASE(OP_REAL_APPLY):
2695 #endif
2696           if (is_proc(sc->code)) {
2697                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
2698           } else if (is_foreign(sc->code))
2699             {
2700               /* Keep nested calls from GC'ing the arglist */
2701               push_recent_alloc(sc,sc->args,sc->NIL);
2702                x=sc->code->_object._ff(sc,sc->args);
2703                s_return(sc,x);
2704           } else if (is_closure(sc->code) || is_macro(sc->code)
2705              || is_promise(sc->code)) { /* CLOSURE */
2706         /* Should not accept promise */
2707                /* make environment */
2708                new_frame_in_env(sc, closure_env(sc->code));
2709                for (x = car(closure_code(sc->code)), y = sc->args;
2710                     is_pair(x); x = cdr(x), y = cdr(y)) {
2711                     if (y == sc->NIL) {
2712                          Error_1(sc, "not enough arguments, missing:", x);
2713                     } else {
2714                          new_slot_in_env(sc, car(x), car(y));
2715                     }
2716                }
2717                if (x == sc->NIL) {
2718                     /*--
2719                      * if (y != sc->NIL) {
2720                      *   Error_0(sc,"too many arguments");
2721                      * }
2722                      */
2723                } else if (is_symbol(x))
2724                     new_slot_in_env(sc, x, y);
2725                else {
2726                     Error_1(sc,"syntax error in closure: not a symbol:", x);
2727                }
2728                sc->code = cdr(closure_code(sc->code));
2729                sc->args = sc->NIL;
2730                s_thread_to(sc,OP_BEGIN);
2731           } else if (is_continuation(sc->code)) { /* CONTINUATION */
2732                sc->dump = cont_dump(sc->code);
2733                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2734           } else {
2735                Error_1(sc,"illegal function",sc->code);
2736           }
2737
2738      CASE(OP_DOMACRO):    /* do macro */
2739           sc->code = sc->value;
2740           s_thread_to(sc,OP_EVAL);
2741
2742 #if USE_COMPILE_HOOK
2743      CASE(OP_LAMBDA):     /* lambda */
2744           /* If the hook is defined, apply it to sc->code, otherwise
2745              set sc->value fall through */
2746           {
2747                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2748                if(f==sc->NIL) {
2749                     sc->value = sc->code;
2750                     /* Fallthru */
2751                } else {
2752                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2753                     sc->args=cons(sc,sc->code,sc->NIL);
2754                     sc->code=slot_value_in_env(f);
2755                     s_thread_to(sc,OP_APPLY);
2756                }
2757           }
2758
2759      CASE(OP_LAMBDA1):
2760           s_return(sc,mk_closure(sc, sc->value, sc->envir));
2761
2762 #else
2763      CASE(OP_LAMBDA):     /* lambda */
2764           s_return(sc,mk_closure(sc, sc->code, sc->envir));
2765
2766 #endif
2767
2768      CASE(OP_MKCLOSURE): /* make-closure */
2769        x=car(sc->args);
2770        if(car(x)==sc->LAMBDA) {
2771          x=cdr(x);
2772        }
2773        if(cdr(sc->args)==sc->NIL) {
2774          y=sc->envir;
2775        } else {
2776          y=cadr(sc->args);
2777        }
2778        s_return(sc,mk_closure(sc, x, y));
2779
2780      CASE(OP_QUOTE):      /* quote */
2781           s_return(sc,car(sc->code));
2782
2783      CASE(OP_DEF0):  /* define */
2784           if(is_immutable(car(sc->code)))
2785             Error_1(sc,"define: unable to alter immutable", car(sc->code));
2786
2787           if (is_pair(car(sc->code))) {
2788                x = caar(sc->code);
2789                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2790           } else {
2791                x = car(sc->code);
2792                sc->code = cadr(sc->code);
2793           }
2794           if (!is_symbol(x)) {
2795                Error_0(sc,"variable is not a symbol");
2796           }
2797           s_save(sc,OP_DEF1, sc->NIL, x);
2798           s_thread_to(sc,OP_EVAL);
2799
2800      CASE(OP_DEF1):  /* define */
2801           x=find_slot_in_env(sc,sc->envir,sc->code,0);
2802           if (x != sc->NIL) {
2803                set_slot_in_env(sc, x, sc->value);
2804           } else {
2805                new_slot_in_env(sc, sc->code, sc->value);
2806           }
2807           s_return(sc,sc->code);
2808
2809
2810      CASE(OP_DEFP):  /* defined? */
2811           x=sc->envir;
2812           if(cdr(sc->args)!=sc->NIL) {
2813                x=cadr(sc->args);
2814           }
2815           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2816
2817      CASE(OP_SET0):       /* set! */
2818           if(is_immutable(car(sc->code)))
2819                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
2820           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2821           sc->code = cadr(sc->code);
2822           s_thread_to(sc,OP_EVAL);
2823
2824      CASE(OP_SET1):       /* set! */
2825           y=find_slot_in_env(sc,sc->envir,sc->code,1);
2826           if (y != sc->NIL) {
2827                set_slot_in_env(sc, y, sc->value);
2828                s_return(sc,sc->value);
2829           } else {
2830                Error_1(sc,"set!: unbound variable:", sc->code);
2831           }
2832
2833
2834      CASE(OP_BEGIN):      /* begin */
2835           if (!is_pair(sc->code)) {
2836                s_return(sc,sc->code);
2837           }
2838           if (cdr(sc->code) != sc->NIL) {
2839                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2840           }
2841           sc->code = car(sc->code);
2842           s_thread_to(sc,OP_EVAL);
2843
2844      CASE(OP_IF0):        /* if */
2845           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2846           sc->code = car(sc->code);
2847           s_thread_to(sc,OP_EVAL);
2848
2849      CASE(OP_IF1):        /* if */
2850           if (is_true(sc->value))
2851                sc->code = car(sc->code);
2852           else
2853                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
2854                                             * car(sc->NIL) = sc->NIL */
2855           s_thread_to(sc,OP_EVAL);
2856
2857      CASE(OP_LET0):       /* let */
2858           sc->args = sc->NIL;
2859           sc->value = sc->code;
2860           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2861           s_thread_to(sc,OP_LET1);
2862
2863      CASE(OP_LET1):       /* let (calculate parameters) */
2864           sc->args = cons(sc, sc->value, sc->args);
2865           if (is_pair(sc->code)) { /* continue */
2866                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2867                     Error_1(sc, "Bad syntax of binding spec in let :",
2868                             car(sc->code));
2869                }
2870                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2871                sc->code = cadar(sc->code);
2872                sc->args = sc->NIL;
2873                s_thread_to(sc,OP_EVAL);
2874           } else {  /* end */
2875                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2876                sc->code = car(sc->args);
2877                sc->args = cdr(sc->args);
2878                s_thread_to(sc,OP_LET2);
2879           }
2880
2881      CASE(OP_LET2):       /* let */
2882           new_frame_in_env(sc, sc->envir);
2883           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2884                y != sc->NIL; x = cdr(x), y = cdr(y)) {
2885                new_slot_in_env(sc, caar(x), car(y));
2886           }
2887           if (is_symbol(car(sc->code))) {    /* named let */
2888                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2889                     if (!is_pair(x))
2890                         Error_1(sc, "Bad syntax of binding in let :", x);
2891                     if (!is_list(sc, car(x)))
2892                         Error_1(sc, "Bad syntax of binding in let :", car(x));
2893                     sc->args = cons(sc, caar(x), sc->args);
2894                }
2895                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2896                new_slot_in_env(sc, car(sc->code), x);
2897                sc->code = cddr(sc->code);
2898                sc->args = sc->NIL;
2899           } else {
2900                sc->code = cdr(sc->code);
2901                sc->args = sc->NIL;
2902           }
2903           s_thread_to(sc,OP_BEGIN);
2904
2905      CASE(OP_LET0AST):    /* let* */
2906           if (car(sc->code) == sc->NIL) {
2907                new_frame_in_env(sc, sc->envir);
2908                sc->code = cdr(sc->code);
2909                s_thread_to(sc,OP_BEGIN);
2910           }
2911           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
2912                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
2913           }
2914           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2915           sc->code = cadaar(sc->code);
2916           s_thread_to(sc,OP_EVAL);
2917
2918      CASE(OP_LET1AST):    /* let* (make new frame) */
2919           new_frame_in_env(sc, sc->envir);
2920           s_thread_to(sc,OP_LET2AST);
2921
2922      CASE(OP_LET2AST):    /* let* (calculate parameters) */
2923           new_slot_in_env(sc, caar(sc->code), sc->value);
2924           sc->code = cdr(sc->code);
2925           if (is_pair(sc->code)) { /* continue */
2926                s_save(sc,OP_LET2AST, sc->args, sc->code);
2927                sc->code = cadar(sc->code);
2928                sc->args = sc->NIL;
2929                s_thread_to(sc,OP_EVAL);
2930           } else {  /* end */
2931                sc->code = sc->args;
2932                sc->args = sc->NIL;
2933                s_thread_to(sc,OP_BEGIN);
2934           }
2935      default:
2936           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
2937           Error_0(sc,sc->strbuff);
2938      }
2939      return sc->T;
2940 }
2941
2942 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2943      pointer x, y;
2944
2945      switch (op) {
2946      CASE(OP_LET0REC):    /* letrec */
2947           new_frame_in_env(sc, sc->envir);
2948           sc->args = sc->NIL;
2949           sc->value = sc->code;
2950           sc->code = car(sc->code);
2951           s_thread_to(sc,OP_LET1REC);
2952
2953      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
2954           sc->args = cons(sc, sc->value, sc->args);
2955           if (is_pair(sc->code)) { /* continue */
2956                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2957                     Error_1(sc, "Bad syntax of binding spec in letrec :",
2958                             car(sc->code));
2959                }
2960                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2961                sc->code = cadar(sc->code);
2962                sc->args = sc->NIL;
2963                s_goto(sc,OP_EVAL);
2964           } else {  /* end */
2965                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2966                sc->code = car(sc->args);
2967                sc->args = cdr(sc->args);
2968                s_thread_to(sc,OP_LET2REC);
2969           }
2970
2971      CASE(OP_LET2REC):    /* letrec */
2972           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2973                new_slot_in_env(sc, caar(x), car(y));
2974           }
2975           sc->code = cdr(sc->code);
2976           sc->args = sc->NIL;
2977           s_goto(sc,OP_BEGIN);
2978
2979      CASE(OP_COND0):      /* cond */
2980           if (!is_pair(sc->code)) {
2981                Error_0(sc,"syntax error in cond");
2982           }
2983           s_save(sc,OP_COND1, sc->NIL, sc->code);
2984           sc->code = caar(sc->code);
2985           s_goto(sc,OP_EVAL);
2986
2987      CASE(OP_COND1):      /* cond */
2988           if (is_true(sc->value)) {
2989                if ((sc->code = cdar(sc->code)) == sc->NIL) {
2990                     s_return(sc,sc->value);
2991                }
2992                if(!sc->code || car(sc->code)==sc->FEED_TO) {
2993                     if(!is_pair(cdr(sc->code))) {
2994                          Error_0(sc,"syntax error in cond");
2995                     }
2996                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2997                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
2998                     s_goto(sc,OP_EVAL);
2999                }
3000                s_goto(sc,OP_BEGIN);
3001           } else {
3002                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3003                     s_return(sc,sc->NIL);
3004                } else {
3005                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3006                     sc->code = caar(sc->code);
3007                     s_goto(sc,OP_EVAL);
3008                }
3009           }
3010
3011      CASE(OP_DELAY):      /* delay */
3012           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3013           typeflag(x)=T_PROMISE;
3014           s_return(sc,x);
3015
3016      CASE(OP_AND0):       /* and */
3017           if (sc->code == sc->NIL) {
3018                s_return(sc,sc->T);
3019           }
3020           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3021           sc->code = car(sc->code);
3022           s_goto(sc,OP_EVAL);
3023
3024      CASE(OP_AND1):       /* and */
3025           if (is_false(sc->value)) {
3026                s_return(sc,sc->value);
3027           } else if (sc->code == sc->NIL) {
3028                s_return(sc,sc->value);
3029           } else {
3030                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3031                sc->code = car(sc->code);
3032                s_goto(sc,OP_EVAL);
3033           }
3034
3035      CASE(OP_OR0):        /* or */
3036           if (sc->code == sc->NIL) {
3037                s_return(sc,sc->F);
3038           }
3039           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3040           sc->code = car(sc->code);
3041           s_goto(sc,OP_EVAL);
3042
3043      CASE(OP_OR1):        /* or */
3044           if (is_true(sc->value)) {
3045                s_return(sc,sc->value);
3046           } else if (sc->code == sc->NIL) {
3047                s_return(sc,sc->value);
3048           } else {
3049                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3050                sc->code = car(sc->code);
3051                s_goto(sc,OP_EVAL);
3052           }
3053
3054      CASE(OP_C0STREAM):   /* cons-stream */
3055           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3056           sc->code = car(sc->code);
3057           s_goto(sc,OP_EVAL);
3058
3059      CASE(OP_C1STREAM):   /* cons-stream */
3060           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3061           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3062           typeflag(x)=T_PROMISE;
3063           s_return(sc,cons(sc, sc->args, x));
3064
3065      CASE(OP_MACRO0):     /* macro */
3066           if (is_pair(car(sc->code))) {
3067                x = caar(sc->code);
3068                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3069           } else {
3070                x = car(sc->code);
3071                sc->code = cadr(sc->code);
3072           }
3073           if (!is_symbol(x)) {
3074                Error_0(sc,"variable is not a symbol");
3075           }
3076           s_save(sc,OP_MACRO1, sc->NIL, x);
3077           s_goto(sc,OP_EVAL);
3078
3079      CASE(OP_MACRO1):     /* macro */
3080           typeflag(sc->value) = T_MACRO;
3081           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3082           if (x != sc->NIL) {
3083                set_slot_in_env(sc, x, sc->value);
3084           } else {
3085                new_slot_in_env(sc, sc->code, sc->value);
3086           }
3087           s_return(sc,sc->code);
3088
3089      CASE(OP_CASE0):      /* case */
3090           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3091           sc->code = car(sc->code);
3092           s_goto(sc,OP_EVAL);
3093
3094      CASE(OP_CASE1):      /* case */
3095           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3096                if (!is_pair(y = caar(x))) {
3097                     break;
3098                }
3099                for ( ; y != sc->NIL; y = cdr(y)) {
3100                     if (eqv(car(y), sc->value)) {
3101                          break;
3102                     }
3103                }
3104                if (y != sc->NIL) {
3105                     break;
3106                }
3107           }
3108           if (x != sc->NIL) {
3109                if (is_pair(caar(x))) {
3110                     sc->code = cdar(x);
3111                     s_goto(sc,OP_BEGIN);
3112                } else {/* else */
3113                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3114                     sc->code = caar(x);
3115                     s_goto(sc,OP_EVAL);
3116                }
3117           } else {
3118                s_return(sc,sc->NIL);
3119           }
3120
3121      CASE(OP_CASE2):      /* case */
3122           if (is_true(sc->value)) {
3123                s_goto(sc,OP_BEGIN);
3124           } else {
3125                s_return(sc,sc->NIL);
3126           }
3127
3128      CASE(OP_PAPPLY):     /* apply */
3129           sc->code = car(sc->args);
3130           sc->args = list_star(sc,cdr(sc->args));
3131           /*sc->args = cadr(sc->args);*/
3132           s_goto(sc,OP_APPLY);
3133
3134      CASE(OP_PEVAL): /* eval */
3135           if(cdr(sc->args)!=sc->NIL) {
3136                sc->envir=cadr(sc->args);
3137           }
3138           sc->code = car(sc->args);
3139           s_goto(sc,OP_EVAL);
3140
3141      CASE(OP_CONTINUATION):    /* call-with-current-continuation */
3142           sc->code = car(sc->args);
3143           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3144           s_goto(sc,OP_APPLY);
3145
3146      default:
3147           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3148           Error_0(sc,sc->strbuff);
3149      }
3150      return sc->T;
3151 }
3152
3153 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3154      pointer x;
3155      num v;
3156 #if USE_MATH
3157      double dd;
3158 #endif
3159
3160      switch (op) {
3161 #if USE_MATH
3162      CASE(OP_INEX2EX):    /* inexact->exact */
3163           x=car(sc->args);
3164           if(num_is_integer(x)) {
3165                s_return(sc,x);
3166           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3167                s_return(sc,mk_integer(sc,ivalue(x)));
3168           } else {
3169                Error_1(sc,"inexact->exact: not integral:",x);
3170           }
3171
3172      CASE(OP_EXP):
3173           x=car(sc->args);
3174           s_return(sc, mk_real(sc, exp(rvalue(x))));
3175
3176      CASE(OP_LOG):
3177           x=car(sc->args);
3178           s_return(sc, mk_real(sc, log(rvalue(x))));
3179
3180      CASE(OP_SIN):
3181           x=car(sc->args);
3182           s_return(sc, mk_real(sc, sin(rvalue(x))));
3183
3184      CASE(OP_COS):
3185           x=car(sc->args);
3186           s_return(sc, mk_real(sc, cos(rvalue(x))));
3187
3188      CASE(OP_TAN):
3189           x=car(sc->args);
3190           s_return(sc, mk_real(sc, tan(rvalue(x))));
3191
3192      CASE(OP_ASIN):
3193           x=car(sc->args);
3194           s_return(sc, mk_real(sc, asin(rvalue(x))));
3195
3196      CASE(OP_ACOS):
3197           x=car(sc->args);
3198           s_return(sc, mk_real(sc, acos(rvalue(x))));
3199
3200      CASE(OP_ATAN):
3201           x=car(sc->args);
3202           if(cdr(sc->args)==sc->NIL) {
3203                s_return(sc, mk_real(sc, atan(rvalue(x))));
3204           } else {
3205                pointer y=cadr(sc->args);
3206                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3207           }
3208
3209      CASE(OP_SQRT):
3210           x=car(sc->args);
3211           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3212
3213      CASE(OP_EXPT): {
3214           double result;
3215           int real_result=1;
3216           pointer y=cadr(sc->args);
3217           x=car(sc->args);
3218           if (num_is_integer(x) && num_is_integer(y))
3219              real_result=0;
3220           /* This 'if' is an R5RS compatibility fix. */
3221           /* NOTE: Remove this 'if' fix for R6RS.    */
3222           if (rvalue(x) == 0 && rvalue(y) < 0) {
3223              result = 0.0;
3224           } else {
3225              result = pow(rvalue(x),rvalue(y));
3226           }
3227           /* Before returning integer result make sure we can. */
3228           /* If the test fails, result is too big for integer. */
3229           if (!real_result)
3230           {
3231             long result_as_long = (long)result;
3232             if (result != (double)result_as_long)
3233               real_result = 1;
3234           }
3235           if (real_result) {
3236              s_return(sc, mk_real(sc, result));
3237           } else {
3238              s_return(sc, mk_integer(sc, result));
3239           }
3240      }
3241
3242      CASE(OP_FLOOR):
3243           x=car(sc->args);
3244           s_return(sc, mk_real(sc, floor(rvalue(x))));
3245
3246      CASE(OP_CEILING):
3247           x=car(sc->args);
3248           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3249
3250      CASE(OP_TRUNCATE ): {
3251           double rvalue_of_x ;
3252           x=car(sc->args);
3253           rvalue_of_x = rvalue(x) ;
3254           if (rvalue_of_x > 0) {
3255             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3256           } else {
3257             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3258           }
3259      }
3260
3261      CASE(OP_ROUND):
3262         x=car(sc->args);
3263         if (num_is_integer(x))
3264             s_return(sc, x);
3265         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3266 #endif
3267
3268      CASE(OP_ADD):        /* + */
3269        v=num_zero;
3270        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3271          v=num_add(v,nvalue(car(x)));
3272        }
3273        s_return(sc,mk_number(sc, v));
3274
3275      CASE(OP_MUL):        /* * */
3276        v=num_one;
3277        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3278          v=num_mul(v,nvalue(car(x)));
3279        }
3280        s_return(sc,mk_number(sc, v));
3281
3282      CASE(OP_SUB):        /* - */
3283        if(cdr(sc->args)==sc->NIL) {
3284          x=sc->args;
3285          v=num_zero;
3286        } else {
3287          x = cdr(sc->args);
3288          v = nvalue(car(sc->args));
3289        }
3290        for (; x != sc->NIL; x = cdr(x)) {
3291          v=num_sub(v,nvalue(car(x)));
3292        }
3293        s_return(sc,mk_number(sc, v));
3294
3295      CASE(OP_DIV):        /* / */
3296        if(cdr(sc->args)==sc->NIL) {
3297          x=sc->args;
3298          v=num_one;
3299        } else {
3300          x = cdr(sc->args);
3301          v = nvalue(car(sc->args));
3302        }
3303        for (; x != sc->NIL; x = cdr(x)) {
3304          if (!is_zero_double(rvalue(car(x))))
3305            v=num_div(v,nvalue(car(x)));
3306          else {
3307            Error_0(sc,"/: division by zero");
3308          }
3309        }
3310        s_return(sc,mk_number(sc, v));
3311
3312      CASE(OP_INTDIV):        /* quotient */
3313           if(cdr(sc->args)==sc->NIL) {
3314                x=sc->args;
3315                v=num_one;
3316           } else {
3317                x = cdr(sc->args);
3318                v = nvalue(car(sc->args));
3319           }
3320           for (; x != sc->NIL; x = cdr(x)) {
3321                if (ivalue(car(x)) != 0)
3322                     v=num_intdiv(v,nvalue(car(x)));
3323                else {
3324                     Error_0(sc,"quotient: division by zero");
3325                }
3326           }
3327           s_return(sc,mk_number(sc, v));
3328
3329      CASE(OP_REM):        /* remainder */
3330           v = nvalue(car(sc->args));
3331           if (ivalue(cadr(sc->args)) != 0)
3332                v=num_rem(v,nvalue(cadr(sc->args)));
3333           else {
3334                Error_0(sc,"remainder: division by zero");
3335           }
3336           s_return(sc,mk_number(sc, v));
3337
3338      CASE(OP_MOD):        /* modulo */
3339           v = nvalue(car(sc->args));
3340           if (ivalue(cadr(sc->args)) != 0)
3341                v=num_mod(v,nvalue(cadr(sc->args)));
3342           else {
3343                Error_0(sc,"modulo: division by zero");
3344           }
3345           s_return(sc,mk_number(sc, v));
3346
3347      CASE(OP_CAR):        /* car */
3348           s_return(sc,caar(sc->args));
3349
3350      CASE(OP_CDR):        /* cdr */
3351           s_return(sc,cdar(sc->args));
3352
3353      CASE(OP_CONS):       /* cons */
3354           cdr(sc->args) = cadr(sc->args);
3355           s_return(sc,sc->args);
3356
3357      CASE(OP_SETCAR):     /* set-car! */
3358        if(!is_immutable(car(sc->args))) {
3359          caar(sc->args) = cadr(sc->args);
3360          s_return(sc,car(sc->args));
3361        } else {
3362          Error_0(sc,"set-car!: unable to alter immutable pair");
3363        }
3364
3365      CASE(OP_SETCDR):     /* set-cdr! */
3366        if(!is_immutable(car(sc->args))) {
3367          cdar(sc->args) = cadr(sc->args);
3368          s_return(sc,car(sc->args));
3369        } else {
3370          Error_0(sc,"set-cdr!: unable to alter immutable pair");
3371        }
3372
3373      CASE(OP_CHAR2INT): { /* char->integer */
3374           char c;
3375           c=(char)ivalue(car(sc->args));
3376           s_return(sc,mk_integer(sc,(unsigned char)c));
3377      }
3378
3379      CASE(OP_INT2CHAR): { /* integer->char */
3380           unsigned char c;
3381           c=(unsigned char)ivalue(car(sc->args));
3382           s_return(sc,mk_character(sc,(char)c));
3383      }
3384
3385      CASE(OP_CHARUPCASE): {
3386           unsigned char c;
3387           c=(unsigned char)ivalue(car(sc->args));
3388           c=toupper(c);
3389           s_return(sc,mk_character(sc,(char)c));
3390      }
3391
3392      CASE(OP_CHARDNCASE): {
3393           unsigned char c;
3394           c=(unsigned char)ivalue(car(sc->args));
3395           c=tolower(c);
3396           s_return(sc,mk_character(sc,(char)c));
3397      }
3398
3399      CASE(OP_STR2SYM):  /* string->symbol */
3400           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3401
3402      CASE(OP_STR2ATOM): /* string->atom */ {
3403           char *s=strvalue(car(sc->args));
3404           long pf = 0;
3405           if(cdr(sc->args)!=sc->NIL) {
3406             /* we know cadr(sc->args) is a natural number */
3407             /* see if it is 2, 8, 10, or 16, or error */
3408             pf = ivalue_unchecked(cadr(sc->args));
3409             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3410                /* base is OK */
3411             }
3412             else {
3413               pf = -1;
3414             }
3415           }
3416           if (pf < 0) {
3417             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3418           } else if(*s=='#') /* no use of base! */ {
3419             s_return(sc, mk_sharp_const(sc, s+1));
3420           } else {
3421             if (pf == 0 || pf == 10) {
3422               s_return(sc, mk_atom(sc, s));
3423             }
3424             else {
3425               char *ep;
3426               long iv = strtol(s,&ep,(int )pf);
3427               if (*ep == 0) {
3428                 s_return(sc, mk_integer(sc, iv));
3429               }
3430               else {
3431                 s_return(sc, sc->F);
3432               }
3433             }
3434           }
3435         }
3436
3437      CASE(OP_SYM2STR): /* symbol->string */
3438           x=mk_string(sc,symname(car(sc->args)));
3439           setimmutable(x);
3440           s_return(sc,x);
3441
3442      CASE(OP_ATOM2STR): /* atom->string */ {
3443           long pf = 0;
3444           x=car(sc->args);
3445           if(cdr(sc->args)!=sc->NIL) {
3446             /* we know cadr(sc->args) is a natural number */
3447             /* see if it is 2, 8, 10, or 16, or error */
3448             pf = ivalue_unchecked(cadr(sc->args));
3449             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
3450               /* base is OK */
3451             }
3452             else {
3453               pf = -1;
3454             }
3455           }
3456           if (pf < 0) {
3457             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
3458           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3459             char *p;
3460             int len;
3461             atom2str(sc,x,(int )pf,&p,&len);
3462             s_return(sc,mk_counted_string(sc,p,len));
3463           } else {
3464             Error_1(sc, "atom->string: not an atom:", x);
3465           }
3466         }
3467
3468      CASE(OP_MKSTRING): { /* make-string */
3469           int fill=' ';
3470           int len;
3471
3472           len=ivalue(car(sc->args));
3473
3474           if(cdr(sc->args)!=sc->NIL) {
3475                fill=charvalue(cadr(sc->args));
3476           }
3477           s_return(sc,mk_empty_string(sc,len,(char)fill));
3478      }
3479
3480      CASE(OP_STRLEN):  /* string-length */
3481           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
3482
3483      CASE(OP_STRREF): { /* string-ref */
3484           char *str;
3485           int index;
3486
3487           str=strvalue(car(sc->args));
3488
3489           index=ivalue(cadr(sc->args));
3490
3491           if(index>=strlength(car(sc->args))) {
3492                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3493           }
3494
3495           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
3496      }
3497
3498      CASE(OP_STRSET): { /* string-set! */
3499           char *str;
3500           int index;
3501           int c;
3502
3503           if(is_immutable(car(sc->args))) {
3504                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3505           }
3506           str=strvalue(car(sc->args));
3507
3508           index=ivalue(cadr(sc->args));
3509           if(index>=strlength(car(sc->args))) {
3510                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3511           }
3512
3513           c=charvalue(caddr(sc->args));
3514
3515           str[index]=(char)c;
3516           s_return(sc,car(sc->args));
3517      }
3518
3519      CASE(OP_STRAPPEND): { /* string-append */
3520        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3521        int len = 0;
3522        pointer newstr;
3523        char *pos;
3524
3525        /* compute needed length for new string */
3526        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3527           len += strlength(car(x));
3528        }
3529        newstr = mk_empty_string(sc, len, ' ');
3530        /* store the contents of the argument strings into the new string */
3531        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3532            pos += strlength(car(x)), x = cdr(x)) {
3533            memcpy(pos, strvalue(car(x)), strlength(car(x)));
3534        }
3535        s_return(sc, newstr);
3536      }
3537
3538      CASE(OP_SUBSTR): { /* substring */
3539           char *str;
3540           int index0;
3541           int index1;
3542           int len;
3543
3544           str=strvalue(car(sc->args));
3545
3546           index0=ivalue(cadr(sc->args));
3547
3548           if(index0>strlength(car(sc->args))) {
3549                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3550           }
3551
3552           if(cddr(sc->args)!=sc->NIL) {
3553                index1=ivalue(caddr(sc->args));
3554                if(index1>strlength(car(sc->args)) || index1<index0) {
3555                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
3556                }
3557           } else {
3558                index1=strlength(car(sc->args));
3559           }
3560
3561           len=index1-index0;
3562           x=mk_empty_string(sc,len,' ');
3563           memcpy(strvalue(x),str+index0,len);
3564           strvalue(x)[len]=0;
3565
3566           s_return(sc,x);
3567      }