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