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