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