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