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