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