gpgscm: Make memory allocation failures fatal.
[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 n) {
962   pointer x = get_cell(sc,sc->NIL, sc->NIL);
963
964   typeflag(x) = (T_NUMBER | T_ATOM);
965   ivalue_unchecked(x)= n;
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 n = ivalue(vec)/2+ivalue(vec)%2;
1032      for(i=0; i < n; 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 n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1244           for(i=0; i < n; 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   (void)sc;
2331   cdr(slot) = value;
2332 }
2333
2334 static INLINE pointer slot_value_in_env(pointer slot)
2335 {
2336   return cdr(slot);
2337 }
2338
2339 /* ========== Evaluation Cycle ========== */
2340
2341
2342 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2343      const char *str = s;
2344 #if USE_ERROR_HOOK
2345      pointer x;
2346      pointer hdl=sc->ERROR_HOOK;
2347 #endif
2348
2349 #if SHOW_ERROR_LINE
2350      char sbuf[STRBUFFSIZE];
2351
2352      /* make sure error is not in REPL */
2353      if (sc->load_stack[sc->file_i].kind & port_file &&
2354          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2355        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2356        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2357
2358        /* should never happen */
2359        if(!fname) fname = "<unknown>";
2360
2361        /* we started from 0 */
2362        ln++;
2363        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2364
2365        str = (const char*)sbuf;
2366      }
2367 #endif
2368
2369 #if USE_ERROR_HOOK
2370      x=find_slot_in_env(sc,sc->envir,hdl,1);
2371     if (x != sc->NIL) {
2372          if(a!=0) {
2373                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2374          } else {
2375                sc->code = sc->NIL;
2376          }
2377          sc->code = cons(sc, mk_string(sc, str), sc->code);
2378          setimmutable(car(sc->code));
2379          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2380          sc->op = (int)OP_EVAL;
2381          return sc->T;
2382     }
2383 #endif
2384
2385     if(a!=0) {
2386           sc->args = cons(sc, (a), sc->NIL);
2387     } else {
2388           sc->args = sc->NIL;
2389     }
2390     sc->args = cons(sc, mk_string(sc, str), sc->args);
2391     setimmutable(car(sc->args));
2392     sc->op = (int)OP_ERR0;
2393     return sc->T;
2394 }
2395 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2396 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2397
2398 /* Too small to turn into function */
2399 # define  BEGIN     do {
2400 # define  END  } while (0)
2401 #define s_goto(sc,a) BEGIN                                  \
2402     sc->op = (int)(a);                                      \
2403     return sc->T; END
2404
2405 #define s_return(sc,a) return _s_return(sc,a)
2406
2407 #ifndef USE_SCHEME_STACK
2408
2409 /* this structure holds all the interpreter's registers */
2410 struct dump_stack_frame {
2411   enum scheme_opcodes op;
2412   pointer args;
2413   pointer envir;
2414   pointer code;
2415 };
2416
2417 #define STACK_GROWTH 3
2418
2419 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
2420 {
2421   int nframes = (int)sc->dump;
2422   struct dump_stack_frame *next_frame;
2423
2424   /* enough room for the next frame? */
2425   if (nframes >= sc->dump_size) {
2426     sc->dump_size += STACK_GROWTH;
2427     /* alas there is no sc->realloc */
2428     sc->dump_base = realloc(sc->dump_base,
2429                             sizeof(struct dump_stack_frame) * sc->dump_size);
2430   }
2431   next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2432   next_frame->op = op;
2433   next_frame->args = args;
2434   next_frame->envir = sc->envir;
2435   next_frame->code = code;
2436   sc->dump = (pointer)(nframes+1);
2437 }
2438
2439 static pointer _s_return(scheme *sc, pointer a)
2440 {
2441   int nframes = (int)sc->dump;
2442   struct dump_stack_frame *frame;
2443
2444   sc->value = (a);
2445   if (nframes <= 0) {
2446     return sc->NIL;
2447   }
2448   nframes--;
2449   frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2450   sc->op = frame->op;
2451   sc->args = frame->args;
2452   sc->envir = frame->envir;
2453   sc->code = frame->code;
2454   sc->dump = (pointer)nframes;
2455   return sc->T;
2456 }
2457
2458 static INLINE void dump_stack_reset(scheme *sc)
2459 {
2460   /* in this implementation, sc->dump is the number of frames on the stack */
2461   sc->dump = (pointer)0;
2462 }
2463
2464 static INLINE void dump_stack_initialize(scheme *sc)
2465 {
2466   sc->dump_size = 0;
2467   sc->dump_base = NULL;
2468   dump_stack_reset(sc);
2469 }
2470
2471 static void dump_stack_free(scheme *sc)
2472 {
2473   free(sc->dump_base);
2474   sc->dump_base = NULL;
2475   sc->dump = (pointer)0;
2476   sc->dump_size = 0;
2477 }
2478
2479 static INLINE void dump_stack_mark(scheme *sc)
2480 {
2481   int nframes = (int)sc->dump;
2482   int i;
2483   for(i=0; i<nframes; i++) {
2484     struct dump_stack_frame *frame;
2485     frame = (struct dump_stack_frame *)sc->dump_base + i;
2486     mark(frame->args);
2487     mark(frame->envir);
2488     mark(frame->code);
2489   }
2490 }
2491
2492 #else
2493
2494 static INLINE void dump_stack_reset(scheme *sc)
2495 {
2496   sc->dump = sc->NIL;
2497 }
2498
2499 static INLINE void dump_stack_initialize(scheme *sc)
2500 {
2501   dump_stack_reset(sc);
2502 }
2503
2504 static void dump_stack_free(scheme *sc)
2505 {
2506   sc->dump = sc->NIL;
2507 }
2508
2509 static pointer _s_return(scheme *sc, pointer a) {
2510     sc->value = (a);
2511     if(sc->dump==sc->NIL) return sc->NIL;
2512     sc->op = ivalue(car(sc->dump));
2513     sc->args = cadr(sc->dump);
2514     sc->envir = caddr(sc->dump);
2515     sc->code = cadddr(sc->dump);
2516     sc->dump = cddddr(sc->dump);
2517     return sc->T;
2518 }
2519
2520 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2521     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2522     sc->dump = cons(sc, (args), sc->dump);
2523     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2524 }
2525
2526 static INLINE void dump_stack_mark(scheme *sc)
2527 {
2528   mark(sc->dump);
2529 }
2530 #endif
2531
2532 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
2533
2534 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2535      pointer x, y;
2536
2537      switch (op) {
2538      case OP_LOAD:       /* load */
2539           if(file_interactive(sc)) {
2540                fprintf(sc->outport->_object._port->rep.stdio.file,
2541                "Loading %s\n", strvalue(car(sc->args)));
2542           }
2543           if (!file_push(sc,strvalue(car(sc->args)))) {
2544                Error_1(sc,"unable to open", car(sc->args));
2545           }
2546       else
2547         {
2548           sc->args = mk_integer(sc,sc->file_i);
2549           s_goto(sc,OP_T0LVL);
2550         }
2551
2552      case OP_T0LVL: /* top level */
2553        /* If we reached the end of file, this loop is done. */
2554        if(sc->loadport->_object._port->kind & port_saw_EOF)
2555      {
2556        if(sc->file_i == 0)
2557          {
2558            sc->args=sc->NIL;
2559            s_goto(sc,OP_QUIT);
2560          }
2561        else
2562          {
2563            file_pop(sc);
2564            s_return(sc,sc->value);
2565          }
2566        /* NOTREACHED */
2567      }
2568
2569        /* If interactive, be nice to user. */
2570        if(file_interactive(sc))
2571      {
2572        sc->envir = sc->global_env;
2573        dump_stack_reset(sc);
2574        putstr(sc,"\n");
2575        putstr(sc,prompt);
2576      }
2577
2578        /* Set up another iteration of REPL */
2579        sc->nesting=0;
2580        sc->save_inport=sc->inport;
2581        sc->inport = sc->loadport;
2582        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2583        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2584        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2585        s_goto(sc,OP_READ_INTERNAL);
2586
2587      case OP_T1LVL: /* top level */
2588           sc->code = sc->value;
2589           sc->inport=sc->save_inport;
2590           s_goto(sc,OP_EVAL);
2591
2592      case OP_READ_INTERNAL:       /* internal read */
2593           sc->tok = token(sc);
2594           if(sc->tok==TOK_EOF)
2595         { s_return(sc,sc->EOF_OBJ); }
2596           s_goto(sc,OP_RDSEXPR);
2597
2598      case OP_GENSYM:
2599           s_return(sc, gensym(sc));
2600
2601      case OP_VALUEPRINT: /* print evaluation result */
2602           /* OP_VALUEPRINT is always pushed, because when changing from
2603              non-interactive to interactive mode, it needs to be
2604              already on the stack */
2605        if(sc->tracing) {
2606          putstr(sc,"\nGives: ");
2607        }
2608        if(file_interactive(sc)) {
2609          sc->print_flag = 1;
2610          sc->args = sc->value;
2611          s_goto(sc,OP_P0LIST);
2612        } else {
2613          s_return(sc,sc->value);
2614        }
2615
2616      case OP_EVAL:       /* main part of evaluation */
2617 #if USE_TRACING
2618        if(sc->tracing) {
2619          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2620          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2621          sc->args=sc->code;
2622          putstr(sc,"\nEval: ");
2623          s_goto(sc,OP_P0LIST);
2624        }
2625        /* fall through */
2626      case OP_REAL_EVAL:
2627 #endif
2628           if (is_symbol(sc->code)) {    /* symbol */
2629                x=find_slot_in_env(sc,sc->envir,sc->code,1);
2630                if (x != sc->NIL) {
2631                     s_return(sc,slot_value_in_env(x));
2632                } else {
2633                     Error_1(sc,"eval: unbound variable:", sc->code);
2634                }
2635           } else if (is_pair(sc->code)) {
2636                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
2637                     sc->code = cdr(sc->code);
2638                     s_goto(sc,syntaxnum(x));
2639                } else {/* first, eval top element and eval arguments */
2640                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2641                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2642                     sc->code = car(sc->code);
2643                     s_goto(sc,OP_EVAL);
2644                }
2645           } else {
2646                s_return(sc,sc->code);
2647           }
2648
2649      case OP_E0ARGS:     /* eval arguments */
2650           if (is_macro(sc->value)) {    /* macro expansion */
2651                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2652                sc->args = cons(sc,sc->code, sc->NIL);
2653                sc->code = sc->value;
2654                s_goto(sc,OP_APPLY);
2655           } else {
2656                sc->code = cdr(sc->code);
2657                s_goto(sc,OP_E1ARGS);
2658           }
2659
2660      case OP_E1ARGS:     /* eval arguments */
2661           sc->args = cons(sc, sc->value, sc->args);
2662           if (is_pair(sc->code)) { /* continue */
2663                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2664                sc->code = car(sc->code);
2665                sc->args = sc->NIL;
2666                s_goto(sc,OP_EVAL);
2667           } else {  /* end */
2668                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2669                sc->code = car(sc->args);
2670                sc->args = cdr(sc->args);
2671                s_goto(sc,OP_APPLY);
2672           }
2673
2674 #if USE_TRACING
2675      case OP_TRACING: {
2676        int tr=sc->tracing;
2677        sc->tracing=ivalue(car(sc->args));
2678        s_return(sc,mk_integer(sc,tr));
2679      }
2680 #endif
2681
2682      case OP_APPLY:      /* apply 'code' to 'args' */
2683 #if USE_TRACING
2684        if(sc->tracing) {
2685          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2686          sc->print_flag = 1;
2687          /*  sc->args=cons(sc,sc->code,sc->args);*/
2688          putstr(sc,"\nApply to: ");
2689          s_goto(sc,OP_P0LIST);
2690        }
2691        /* fall through */
2692      case OP_REAL_APPLY:
2693 #endif
2694           if (is_proc(sc->code)) {
2695                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
2696           } else if (is_foreign(sc->code))
2697             {
2698               /* Keep nested calls from GC'ing the arglist */
2699               push_recent_alloc(sc,sc->args,sc->NIL);
2700                x=sc->code->_object._ff(sc,sc->args);
2701                s_return(sc,x);
2702           } else if (is_closure(sc->code) || is_macro(sc->code)
2703              || is_promise(sc->code)) { /* CLOSURE */
2704         /* Should not accept promise */
2705                /* make environment */
2706                new_frame_in_env(sc, closure_env(sc->code));
2707                for (x = car(closure_code(sc->code)), y = sc->args;
2708                     is_pair(x); x = cdr(x), y = cdr(y)) {
2709                     if (y == sc->NIL) {
2710                          Error_0(sc,"not enough arguments");
2711                     } else {
2712                          new_slot_in_env(sc, car(x), car(y));
2713                     }
2714                }
2715                if (x == sc->NIL) {
2716                     /*--
2717                      * if (y != sc->NIL) {
2718                      *   Error_0(sc,"too many arguments");
2719                      * }
2720                      */
2721                } else if (is_symbol(x))
2722                     new_slot_in_env(sc, x, y);
2723                else {
2724                     Error_1(sc,"syntax error in closure: not a symbol:", x);
2725                }
2726                sc->code = cdr(closure_code(sc->code));
2727                sc->args = sc->NIL;
2728                s_goto(sc,OP_BEGIN);
2729           } else if (is_continuation(sc->code)) { /* CONTINUATION */
2730                sc->dump = cont_dump(sc->code);
2731                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2732           } else {
2733                Error_1(sc,"illegal function",sc->code);
2734           }
2735
2736      case OP_DOMACRO:    /* do macro */
2737           sc->code = sc->value;
2738           s_goto(sc,OP_EVAL);
2739
2740 #if 1
2741      case OP_LAMBDA:     /* lambda */
2742           /* If the hook is defined, apply it to sc->code, otherwise
2743              set sc->value fall thru */
2744           {
2745                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2746                if(f==sc->NIL) {
2747                     sc->value = sc->code;
2748                     /* Fallthru */
2749                } else {
2750                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2751                     sc->args=cons(sc,sc->code,sc->NIL);
2752                     sc->code=slot_value_in_env(f);
2753                     s_goto(sc,OP_APPLY);
2754                }
2755           }
2756
2757      case OP_LAMBDA1:
2758           s_return(sc,mk_closure(sc, sc->value, sc->envir));
2759
2760 #else
2761      case OP_LAMBDA:     /* lambda */
2762           s_return(sc,mk_closure(sc, sc->code, sc->envir));
2763
2764 #endif
2765
2766      case OP_MKCLOSURE: /* make-closure */
2767        x=car(sc->args);
2768        if(car(x)==sc->LAMBDA) {
2769          x=cdr(x);
2770        }
2771        if(cdr(sc->args)==sc->NIL) {
2772          y=sc->envir;
2773        } else {
2774          y=cadr(sc->args);
2775        }
2776        s_return(sc,mk_closure(sc, x, y));
2777
2778      case OP_QUOTE:      /* quote */
2779           s_return(sc,car(sc->code));
2780
2781      case OP_DEF0:  /* define */
2782           if(is_immutable(car(sc->code)))
2783             Error_1(sc,"define: unable to alter immutable", car(sc->code));
2784
2785           if (is_pair(car(sc->code))) {
2786                x = caar(sc->code);
2787                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2788           } else {
2789                x = car(sc->code);
2790                sc->code = cadr(sc->code);
2791           }
2792           if (!is_symbol(x)) {
2793                Error_0(sc,"variable is not a symbol");
2794           }
2795           s_save(sc,OP_DEF1, sc->NIL, x);
2796           s_goto(sc,OP_EVAL);
2797
2798      case OP_DEF1:  /* define */
2799           x=find_slot_in_env(sc,sc->envir,sc->code,0);
2800           if (x != sc->NIL) {
2801                set_slot_in_env(sc, x, sc->value);
2802           } else {
2803                new_slot_in_env(sc, sc->code, sc->value);
2804           }
2805           s_return(sc,sc->code);
2806
2807
2808      case OP_DEFP:  /* defined? */
2809           x=sc->envir;
2810           if(cdr(sc->args)!=sc->NIL) {
2811                x=cadr(sc->args);
2812           }
2813           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2814
2815      case OP_SET0:       /* set! */
2816           if(is_immutable(car(sc->code)))
2817                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
2818           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2819           sc->code = cadr(sc->code);
2820           s_goto(sc,OP_EVAL);
2821
2822      case OP_SET1:       /* set! */
2823           y=find_slot_in_env(sc,sc->envir,sc->code,1);
2824           if (y != sc->NIL) {
2825                set_slot_in_env(sc, y, sc->value);
2826                s_return(sc,sc->value);
2827           } else {
2828                Error_1(sc,"set!: unbound variable:", sc->code);
2829           }
2830
2831
2832      case OP_BEGIN:      /* begin */
2833           if (!is_pair(sc->code)) {
2834                s_return(sc,sc->code);
2835           }
2836           if (cdr(sc->code) != sc->NIL) {
2837                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2838           }
2839           sc->code = car(sc->code);
2840           s_goto(sc,OP_EVAL);
2841
2842      case OP_IF0:        /* if */
2843           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2844           sc->code = car(sc->code);
2845           s_goto(sc,OP_EVAL);
2846
2847      case OP_IF1:        /* if */
2848           if (is_true(sc->value))
2849                sc->code = car(sc->code);
2850           else
2851                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
2852                                             * car(sc->NIL) = sc->NIL */
2853           s_goto(sc,OP_EVAL);
2854
2855      case OP_LET0:       /* let */
2856           sc->args = sc->NIL;
2857           sc->value = sc->code;
2858           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2859           s_goto(sc,OP_LET1);
2860
2861      case OP_LET1:       /* let (calculate parameters) */
2862           sc->args = cons(sc, sc->value, sc->args);
2863           if (is_pair(sc->code)) { /* continue */
2864                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2865                     Error_1(sc, "Bad syntax of binding spec in let :",
2866                             car(sc->code));
2867                }
2868                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2869                sc->code = cadar(sc->code);
2870                sc->args = sc->NIL;
2871                s_goto(sc,OP_EVAL);
2872           } else {  /* end */
2873                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2874                sc->code = car(sc->args);
2875                sc->args = cdr(sc->args);
2876                s_goto(sc,OP_LET2);
2877           }
2878
2879      case OP_LET2:       /* let */
2880           new_frame_in_env(sc, sc->envir);
2881           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2882                y != sc->NIL; x = cdr(x), y = cdr(y)) {
2883                new_slot_in_env(sc, caar(x), car(y));
2884           }
2885           if (is_symbol(car(sc->code))) {    /* named let */
2886                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2887                     if (!is_pair(x))
2888                         Error_1(sc, "Bad syntax of binding in let :", x);
2889                     if (!is_list(sc, car(x)))
2890                         Error_1(sc, "Bad syntax of binding in let :", car(x));
2891                     sc->args = cons(sc, caar(x), sc->args);
2892                }
2893                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2894                new_slot_in_env(sc, car(sc->code), x);
2895                sc->code = cddr(sc->code);
2896                sc->args = sc->NIL;
2897           } else {
2898                sc->code = cdr(sc->code);
2899                sc->args = sc->NIL;
2900           }
2901           s_goto(sc,OP_BEGIN);
2902
2903      case OP_LET0AST:    /* let* */
2904           if (car(sc->code) == sc->NIL) {
2905                new_frame_in_env(sc, sc->envir);
2906                sc->code = cdr(sc->code);
2907                s_goto(sc,OP_BEGIN);
2908           }
2909           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
2910                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
2911           }
2912           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2913           sc->code = cadaar(sc->code);
2914           s_goto(sc,OP_EVAL);
2915
2916      case OP_LET1AST:    /* let* (make new frame) */
2917           new_frame_in_env(sc, sc->envir);
2918           s_goto(sc,OP_LET2AST);
2919
2920      case OP_LET2AST:    /* let* (calculate parameters) */
2921           new_slot_in_env(sc, caar(sc->code), sc->value);
2922           sc->code = cdr(sc->code);
2923           if (is_pair(sc->code)) { /* continue */
2924                s_save(sc,OP_LET2AST, sc->args, sc->code);
2925                sc->code = cadar(sc->code);
2926                sc->args = sc->NIL;
2927                s_goto(sc,OP_EVAL);
2928           } else {  /* end */
2929                sc->code = sc->args;
2930                sc->args = sc->NIL;
2931                s_goto(sc,OP_BEGIN);
2932           }
2933      default:
2934           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
2935           Error_0(sc,sc->strbuff);
2936      }
2937      return sc->T;
2938 }
2939
2940 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2941      pointer x, y;
2942
2943      switch (op) {
2944      case OP_LET0REC:    /* letrec */
2945           new_frame_in_env(sc, sc->envir);
2946           sc->args = sc->NIL;
2947           sc->value = sc->code;
2948           sc->code = car(sc->code);
2949           s_goto(sc,OP_LET1REC);
2950
2951      case OP_LET1REC:    /* letrec (calculate parameters) */
2952           sc->args = cons(sc, sc->value, sc->args);
2953           if (is_pair(sc->code)) { /* continue */
2954                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2955                     Error_1(sc, "Bad syntax of binding spec in letrec :",
2956                             car(sc->code));
2957                }
2958                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2959                sc->code = cadar(sc->code);
2960                sc->args = sc->NIL;
2961                s_goto(sc,OP_EVAL);
2962           } else {  /* end */
2963                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2964                sc->code = car(sc->args);
2965                sc->args = cdr(sc->args);
2966                s_goto(sc,OP_LET2REC);
2967           }
2968
2969      case OP_LET2REC:    /* letrec */
2970           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2971                new_slot_in_env(sc, caar(x), car(y));
2972           }
2973           sc->code = cdr(sc->code);
2974           sc->args = sc->NIL;
2975           s_goto(sc,OP_BEGIN);
2976
2977      case OP_COND0:      /* cond */
2978           if (!is_pair(sc->code)) {
2979                Error_0(sc,"syntax error in cond");
2980           }
2981           s_save(sc,OP_COND1, sc->NIL, sc->code);
2982           sc->code = caar(sc->code);
2983           s_goto(sc,OP_EVAL);
2984
2985      case OP_COND1:      /* cond */
2986           if (is_true(sc->value)) {
2987                if ((sc->code = cdar(sc->code)) == sc->NIL) {
2988                     s_return(sc,sc->value);
2989                }
2990                if(!sc->code || car(sc->code)==sc->FEED_TO) {
2991                     if(!is_pair(cdr(sc->code))) {
2992                          Error_0(sc,"syntax error in cond");
2993                     }
2994                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2995                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
2996                     s_goto(sc,OP_EVAL);
2997                }
2998                s_goto(sc,OP_BEGIN);
2999           } else {
3000                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3001                     s_return(sc,sc->NIL);
3002                } else {
3003                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3004                     sc->code = caar(sc->code);
3005                     s_goto(sc,OP_EVAL);
3006                }
3007           }
3008
3009      case OP_DELAY:      /* delay */
3010           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3011           typeflag(x)=T_PROMISE;
3012           s_return(sc,x);
3013
3014      case OP_AND0:       /* and */
3015           if (sc->code == sc->NIL) {
3016                s_return(sc,sc->T);
3017           }
3018           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3019           sc->code = car(sc->code);
3020           s_goto(sc,OP_EVAL);
3021
3022      case OP_AND1:       /* and */
3023           if (is_false(sc->value)) {
3024                s_return(sc,sc->value);
3025           } else if (sc->code == sc->NIL) {
3026                s_return(sc,sc->value);
3027           } else {
3028                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3029                sc->code = car(sc->code);
3030                s_goto(sc,OP_EVAL);
3031           }
3032
3033      case OP_OR0:        /* or */
3034           if (sc->code == sc->NIL) {
3035                s_return(sc,sc->F);
3036           }
3037           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3038           sc->code = car(sc->code);
3039           s_goto(sc,OP_EVAL);
3040
3041      case OP_OR1:        /* or */
3042           if (is_true(sc->value)) {
3043                s_return(sc,sc->value);
3044           } else if (sc->code == sc->NIL) {
3045                s_return(sc,sc->value);
3046           } else {
3047                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3048                sc->code = car(sc->code);
3049                s_goto(sc,OP_EVAL);
3050           }
3051
3052      case OP_C0STREAM:   /* cons-stream */
3053           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3054           sc->code = car(sc->code);
3055           s_goto(sc,OP_EVAL);
3056
3057      case OP_C1STREAM:   /* cons-stream */
3058           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3059           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3060           typeflag(x)=T_PROMISE;
3061           s_return(sc,cons(sc, sc->args, x));
3062
3063      case OP_MACRO0:     /* macro */
3064           if (is_pair(car(sc->code))) {
3065                x = caar(sc->code);
3066                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3067           } else {
3068                x = car(sc->code);
3069                sc->code = cadr(sc->code);
3070           }
3071           if (!is_symbol(x)) {
3072                Error_0(sc,"variable is not a symbol");
3073           }
3074           s_save(sc,OP_MACRO1, sc->NIL, x);
3075           s_goto(sc,OP_EVAL);
3076
3077      case OP_MACRO1:     /* macro */
3078           typeflag(sc->value) = T_MACRO;
3079           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3080           if (x != sc->NIL) {
3081                set_slot_in_env(sc, x, sc->value);
3082           } else {
3083                new_slot_in_env(sc, sc->code, sc->value);
3084           }
3085           s_return(sc,sc->code);
3086
3087      case OP_CASE0:      /* case */
3088           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3089           sc->code = car(sc->code);
3090           s_goto(sc,OP_EVAL);
3091
3092      case OP_CASE1:      /* case */
3093           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3094                if (!is_pair(y = caar(x))) {
3095                     break;
3096                }
3097                for ( ; y != sc->NIL; y = cdr(y)) {
3098                     if (eqv(car(y), sc->value)) {
3099                          break;
3100                     }
3101                }
3102                if (y != sc->NIL) {
3103                     break;
3104                }
3105           }
3106           if (x != sc->NIL) {
3107                if (is_pair(caar(x))) {
3108                     sc->code = cdar(x);
3109                     s_goto(sc,OP_BEGIN);
3110                } else {/* else */
3111                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3112                     sc->code = caar(x);
3113                     s_goto(sc,OP_EVAL);
3114                }
3115           } else {
3116                s_return(sc,sc->NIL);
3117           }
3118
3119      case OP_CASE2:      /* case */
3120           if (is_true(sc->value)) {
3121                s_goto(sc,OP_BEGIN);
3122           } else {
3123                s_return(sc,sc->NIL);
3124           }
3125
3126      case OP_PAPPLY:     /* apply */
3127           sc->code = car(sc->args);
3128           sc->args = list_star(sc,cdr(sc->args));
3129           /*sc->args = cadr(sc->args);*/
3130           s_goto(sc,OP_APPLY);
3131
3132      case OP_PEVAL: /* eval */
3133           if(cdr(sc->args)!=sc->NIL) {
3134                sc->envir=cadr(sc->args);
3135           }
3136           sc->code = car(sc->args);
3137           s_goto(sc,OP_EVAL);
3138
3139      case OP_CONTINUATION:    /* call-with-current-continuation */
3140           sc->code = car(sc->args);
3141           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3142           s_goto(sc,OP_APPLY);
3143
3144      default:
3145           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3146           Error_0(sc,sc->strbuff);
3147      }
3148      return sc->T;
3149 }
3150
3151 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3152      pointer x;
3153      num v;
3154 #if USE_MATH
3155      double dd;
3156 #endif
3157
3158      switch (op) {
3159 #if USE_MATH
3160      case OP_INEX2EX:    /* inexact->exact */
3161           x=car(sc->args);
3162           if(num_is_integer(x)) {
3163                s_return(sc,x);
3164           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3165                s_return(sc,mk_integer(sc,ivalue(x)));
3166           } else {
3167                Error_1(sc,"inexact->exact: not integral:",x);
3168           }
3169
3170      case OP_EXP:
3171           x=car(sc->args);
3172           s_return(sc, mk_real(sc, exp(rvalue(x))));
3173
3174      case OP_LOG:
3175           x=car(sc->args);
3176           s_return(sc, mk_real(sc, log(rvalue(x))));
3177
3178      case OP_SIN:
3179           x=car(sc->args);
3180           s_return(sc, mk_real(sc, sin(rvalue(x))));
3181
3182      case OP_COS:
3183           x=car(sc->args);
3184           s_return(sc, mk_real(sc, cos(rvalue(x))));
3185
3186      case OP_TAN:
3187           x=car(sc->args);
3188           s_return(sc, mk_real(sc, tan(rvalue(x))));
3189
3190      case OP_ASIN:
3191           x=car(sc->args);
3192           s_return(sc, mk_real(sc, asin(rvalue(x))));
3193
3194      case OP_ACOS:
3195           x=car(sc->args);
3196           s_return(sc, mk_real(sc, acos(rvalue(x))));
3197
3198      case OP_ATAN:
3199           x=car(sc->args);
3200           if(cdr(sc->args)==sc->NIL) {
3201                s_return(sc, mk_real(sc, atan(rvalue(x))));
3202           } else {
3203                pointer y=cadr(sc->args);
3204                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3205           }
3206
3207      case OP_SQRT:
3208           x=car(sc->args);
3209           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3210
3211      case OP_EXPT: {
3212           double result;
3213           int real_result=1;
3214           pointer y=cadr(sc->args);
3215           x=car(sc->args);
3216           if (num_is_integer(x) && num_is_integer(y))
3217              real_result=0;
3218           /* This 'if' is an R5RS compatibility fix. */
3219           /* NOTE: Remove this 'if' fix for R6RS.    */
3220           if (rvalue(x) == 0 && rvalue(y) < 0) {
3221              result = 0.0;
3222           } else {
3223              result = pow(rvalue(x),rvalue(y));
3224           }
3225           /* Before returning integer result make sure we can. */
3226           /* If the test fails, result is too big for integer. */
3227           if (!real_result)
3228           {
3229             long result_as_long = (long)result;
3230             if (result != (double)result_as_long)
3231               real_result = 1;
3232           }
3233           if (real_result) {
3234              s_return(sc, mk_real(sc, result));
3235           } else {
3236              s_return(sc, mk_integer(sc, result));
3237           }
3238      }
3239
3240      case OP_FLOOR:
3241           x=car(sc->args);
3242           s_return(sc, mk_real(sc, floor(rvalue(x))));
3243
3244      case OP_CEILING:
3245           x=car(sc->args);
3246           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3247
3248      case OP_TRUNCATE : {
3249           double rvalue_of_x ;
3250           x=car(sc->args);
3251           rvalue_of_x = rvalue(x) ;
3252           if (rvalue_of_x > 0) {
3253             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3254           } else {
3255             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3256           }
3257      }
3258
3259      case OP_ROUND:
3260         x=car(sc->args);
3261         if (num_is_integer(x))
3262             s_return(sc, x);
3263         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3264 #endif
3265
3266      case OP_ADD:        /* + */
3267        v=num_zero;
3268        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3269          v=num_add(v,nvalue(car(x)));
3270        }
3271        s_return(sc,mk_number(sc, v));
3272
3273      case OP_MUL:        /* * */
3274        v=num_one;
3275        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3276          v=num_mul(v,nvalue(car(x)));
3277        }
3278        s_return(sc,mk_number(sc, v));
3279
3280      case OP_SUB:        /* - */
3281        if(cdr(sc->args)==sc->NIL) {
3282          x=sc->args;
3283          v=num_zero;
3284        } else {
3285          x = cdr(sc->args);
3286          v = nvalue(car(sc->args));
3287        }
3288        for (; x != sc->NIL; x = cdr(x)) {
3289          v=num_sub(v,nvalue(car(x)));
3290        }
3291        s_return(sc,mk_number(sc, v));
3292
3293      case OP_DIV:        /* / */
3294        if(cdr(sc->args)==sc->NIL) {
3295          x=sc->args;
3296          v=num_one;
3297        } else {
3298          x = cdr(sc->args);
3299          v = nvalue(car(sc->args));
3300        }
3301        for (; x != sc->NIL; x = cdr(x)) {
3302          if (!is_zero_double(rvalue(car(x))))
3303            v=num_div(v,nvalue(car(x)));
3304          else {
3305            Error_0(sc,"/: division by zero");
3306          }
3307        }
3308        s_return(sc,mk_number(sc, v));
3309
3310      case OP_INTDIV:        /* quotient */
3311           if(cdr(sc->args)==sc->NIL) {
3312                x=sc->args;
3313                v=num_one;
3314           } else {
3315                x = cdr(sc->args);
3316                v = nvalue(car(sc->args));
3317           }
3318           for (; x != sc->NIL; x = cdr(x)) {
3319                if (ivalue(car(x)) != 0)
3320                     v=num_intdiv(v,nvalue(car(x)));
3321                else {
3322                     Error_0(sc,"quotient: division by zero");
3323                }
3324           }
3325           s_return(sc,mk_number(sc, v));
3326
3327      case OP_REM:        /* remainder */
3328           v = nvalue(car(sc->args));
3329           if (ivalue(cadr(sc->args)) != 0)
3330                v=num_rem(v,nvalue(cadr(sc->args)));
3331           else {
3332                Error_0(sc,"remainder: division by zero");
3333           }
3334           s_return(sc,mk_number(sc, v));
3335
3336      case OP_MOD:        /* modulo */
3337           v = nvalue(car(sc->args));
3338           if (ivalue(cadr(sc->args)) != 0)
3339                v=num_mod(v,nvalue(cadr(sc->args)));
3340           else {
3341                Error_0(sc,"modulo: division by zero");
3342           }
3343           s_return(sc,mk_number(sc, v));
3344
3345      case OP_CAR:        /* car */
3346           s_return(sc,caar(sc->args));
3347
3348      case OP_CDR:        /* cdr */
3349           s_return(sc,cdar(sc->args));
3350
3351      case OP_CONS:       /* cons */
3352           cdr(sc->args) = cadr(sc->args);
3353           s_return(sc,sc->args);
3354
3355      case OP_SETCAR:     /* set-car! */
3356        if(!is_immutable(car(sc->args))) {
3357          caar(sc->args) = cadr(sc->args);
3358          s_return(sc,car(sc->args));
3359        } else {
3360          Error_0(sc,"set-car!: unable to alter immutable pair");
3361        }
3362
3363      case OP_SETCDR:     /* set-cdr! */
3364        if(!is_immutable(car(sc->args))) {
3365          cdar(sc->args) = cadr(sc->args);
3366          s_return(sc,car(sc->args));
3367        } else {
3368          Error_0(sc,"set-cdr!: unable to alter immutable pair");
3369        }
3370
3371      case OP_CHAR2INT: { /* char->integer */
3372           char c;
3373           c=(char)ivalue(car(sc->args));
3374           s_return(sc,mk_integer(sc,(unsigned char)c));
3375      }
3376
3377      case OP_INT2CHAR: { /* integer->char */
3378           unsigned char c;
3379           c=(unsigned char)ivalue(car(sc->args));
3380           s_return(sc,mk_character(sc,(char)c));
3381      }
3382
3383      case OP_CHARUPCASE: {
3384           unsigned char c;
3385           c=(unsigned char)ivalue(car(sc->args));
3386           c=toupper(c);
3387           s_return(sc,mk_character(sc,(char)c));
3388      }
3389
3390      case OP_CHARDNCASE: {
3391           unsigned char c;
3392           c=(unsigned char)ivalue(car(sc->args));
3393           c=tolower(c);
3394           s_return(sc,mk_character(sc,(char)c));
3395      }
3396
3397      case OP_STR2SYM:  /* string->symbol */
3398           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3399
3400      case OP_STR2ATOM: /* string->atom */ {
3401           char *s=strvalue(car(sc->args));
3402           long pf = 0;
3403           if(cdr(sc->args)!=sc->NIL) {
3404             /* we know cadr(sc->args) is a natural number */
3405             /* see if it is 2, 8, 10, or 16, or error */
3406             pf = ivalue_unchecked(cadr(sc->args));
3407             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3408                /* base is OK */
3409             }
3410             else {
3411               pf = -1;
3412             }
3413           }
3414           if (pf < 0) {
3415             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3416           } else if(*s=='#') /* no use of base! */ {
3417             s_return(sc, mk_sharp_const(sc, s+1));
3418           } else {
3419             if (pf == 0 || pf == 10) {
3420               s_return(sc, mk_atom(sc, s));
3421             }
3422             else {
3423               char *ep;
3424               long iv = strtol(s,&ep,(int )pf);
3425               if (*ep == 0) {
3426                 s_return(sc, mk_integer(sc, iv));
3427               }
3428               else {
3429                 s_return(sc, sc->F);
3430               }
3431             }
3432           }
3433         }
3434
3435      case OP_SYM2STR: /* symbol->string */
3436           x=mk_string(sc,symname(car(sc->args)));
3437           setimmutable(x);
3438           s_return(sc,x);
3439
3440      case OP_ATOM2STR: /* atom->string */ {
3441           long pf = 0;
3442           x=car(sc->args);
3443           if(cdr(sc->args)!=sc->NIL) {
3444             /* we know cadr(sc->args) is a natural number */
3445             /* see if it is 2, 8, 10, or 16, or error */
3446             pf = ivalue_unchecked(cadr(sc->args));
3447             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
3448               /* base is OK */
3449             }
3450             else {
3451               pf = -1;
3452             }
3453           }
3454           if (pf < 0) {
3455             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
3456           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3457             char *p;
3458             int len;
3459             atom2str(sc,x,(int )pf,&p,&len);
3460             s_return(sc,mk_counted_string(sc,p,len));
3461           } else {
3462             Error_1(sc, "atom->string: not an atom:", x);
3463           }
3464         }
3465
3466      case OP_MKSTRING: { /* make-string */
3467           int fill=' ';
3468           int len;
3469
3470           len=ivalue(car(sc->args));
3471
3472           if(cdr(sc->args)!=sc->NIL) {
3473                fill=charvalue(cadr(sc->args));
3474           }
3475           s_return(sc,mk_empty_string(sc,len,(char)fill));
3476      }
3477
3478      case OP_STRLEN:  /* string-length */
3479           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
3480
3481      case OP_STRREF: { /* string-ref */
3482           char *str;
3483           int index;
3484
3485           str=strvalue(car(sc->args));
3486
3487           index=ivalue(cadr(sc->args));
3488
3489           if(index>=strlength(car(sc->args))) {
3490                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3491           }
3492
3493           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
3494      }
3495
3496      case OP_STRSET: { /* string-set! */
3497           char *str;
3498           int index;
3499           int c;
3500
3501           if(is_immutable(car(sc->args))) {
3502                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3503           }
3504           str=strvalue(car(sc->args));
3505
3506           index=ivalue(cadr(sc->args));
3507           if(index>=strlength(car(sc->args))) {
3508                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3509           }
3510
3511           c=charvalue(caddr(sc->args));
3512
3513           str[index]=(char)c;
3514           s_return(sc,car(sc->args));
3515      }
3516
3517      case OP_STRAPPEND: { /* string-append */
3518        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3519        int len = 0;
3520        pointer newstr;
3521        char *pos;
3522
3523        /* compute needed length for new string */
3524        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3525           len += strlength(car(x));
3526        }
3527        newstr = mk_empty_string(sc, len, ' ');
3528        /* store the contents of the argument strings into the new string */
3529        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3530            pos += strlength(car(x)), x = cdr(x)) {
3531            memcpy(pos, strvalue(car(x)), strlength(car(x)));
3532        }
3533        s_return(sc, newstr);
3534      }
3535
3536      case OP_SUBSTR: { /* substring */
3537           char *str;
3538           int index0;
3539           int index1;
3540           int len;
3541
3542           str=strvalue(car(sc->args));
3543
3544           index0=ivalue(cadr(sc->args));
3545
3546           if(index0>strlength(car(sc->args))) {
3547                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3548           }
3549
3550           if(cddr(sc->args)!=sc->NIL) {
3551                index1=ivalue(caddr(sc->args));
3552                if(index1>strlength(car(sc->args)) || index1<index0) {
3553                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
3554                }
3555           } else {
3556                index1=strlength(car(sc->args));
3557           }
3558
3559           len=index1-index0;
3560           x=mk_empty_string(sc,len,' ');
3561           memcpy(strvalue(x),str+index0,len);
3562           strvalue(x)[len]=0;
3563
3564           s_return(sc,x);
3565      }
3566
3567      case OP_VECTOR: {   /* vector */
3568           int i;
3569           pointer vec;
3570           int len=list_length(sc,sc->args);
3571           if(len<0) {
3572                Error_1(sc,"vector: not a proper list:",sc->args);
3573           }
3574           vec=mk_vector(sc,len);
3575           if(sc->no_memory) { s_return(sc, sc->sink); }
3576           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3577                set_vector_elem(vec,i,car(x));
3578           }
3579           s_return(sc,vec);
3580      }
3581
3582      case OP_MKVECTOR: { /* make-vector */
3583           pointer fill=sc->NIL;
3584           int len;
3585           pointer vec;
3586
3587           len=ivalue(car(sc->args));
3588
3589           if(cdr(sc->args)!=sc->NIL) {
3590                fill=cadr(sc->args);
3591           }
3592           vec=mk_vector(sc,len);
3593           if(sc->no_memory) { s_return(sc, sc->sink); }
3594           if(fill!=sc->NIL) {
3595                fill_vector(vec,fill);
3596           }
3597           s_return(sc,vec);
3598      }
3599
3600      case OP_VECLEN:  /* vector-length */
3601           s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
3602
3603      case OP_VECREF: { /* vector-ref */
3604           int index;
3605
3606           index=ivalue(cadr(sc->args));
3607
3608           if(index>=ivalue(car(sc->args))) {
3609                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
3610           }
3611
3612           s_return(sc,vector_elem(car(sc->args),index));
3613      }
3614
3615      case OP_VECSET: {   /* vector-set! */
3616           int index;
3617
3618           if(is_immutable(car(sc->args))) {
3619                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
3620           }
3621
3622           index=ivalue(cadr(sc->args));
3623           if(index>=ivalue(car(sc->args))) {
3624                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
3625           }
3626
3627           set_vector_elem(car(sc->args),index,caddr(sc->args));
3628           s_return(sc,car(sc->args));
3629      }
3630
3631      default:
3632           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3633           Error_0(sc,sc->strbuff);
3634      }
3635      return sc->T;
3636 }
3637
3638 static int is_list(scheme *sc, pointer a)
3639 { return list_length(sc,a) >= 0; }
3640
3641 /* Result is:
3642    proper list: length
3643    circular list: -1
3644    not even a pair: -2
3645    dotted list: -2 minus length before dot
3646 */
3647 int list_length(scheme *sc, pointer a) {
3648     int i=0;
3649     pointer slow, fast;
3650
3651     slow = fast = a;
3652     while (1)
3653     {
3654         if (fast == sc->NIL)
3655                 return i;
3656         if (!is_pair(fast))
3657                 return -2 - i;
3658         fast = cdr(fast);
3659         ++i;
3660         if (fast == sc->NIL)
3661                 return i;
3662         if (!is_pair(fast))
3663                 return -2 - i;
3664         ++i;
3665         fast = cdr(fast);
3666
3667         /* Safe because we would have already returned if `fast'
3668            encountered a non-pair. */
3669         slow = cdr(slow);
3670         if (fast == slow)
3671         {
3672             /* the fast pointer has looped back around and caught up
3673                with the slow pointer, hence the structure is circular,
3674                not of finite length, and therefore not a list */
3675             return -1;
3676         }
3677     }
3678 }
3679
3680 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
3681      pointer x;
3682      num v;
3683      int (*comp_func)(num,num)=0;
3684
3685      switch (op) {
3686      case OP_NOT:        /* not */
3687           s_retbool(is_false(car(sc->args)));
3688      case OP_BOOLP:       /* boolean? */
3689           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3690      case OP_EOFOBJP:       /* boolean? */
3691           s_retbool(car(sc->args) == sc->EOF_OBJ);
3692      case OP_NULLP:       /* null? */
3693           s_retbool(car(sc->args) == sc->NIL);
3694      case OP_NUMEQ:      /* = */
3695      case OP_LESS:       /* < */
3696      case OP_GRE:        /* > */
3697      case OP_LEQ:        /* <= */
3698      case OP_GEQ:        /* >= */
3699           switch(op) {
3700                case OP_NUMEQ: comp_func=num_eq; break;
3701                case OP_LESS:  comp_func=num_lt; break;
3702                case OP_GRE:   comp_func=num_gt; break;
3703                case OP_LEQ:   comp_func=num_le; break;
3704                case OP_GEQ:   comp_func=num_ge; break;
3705                default: assert (! "reached");
3706           }
3707           x=sc->args;
3708           v=nvalue(car(x));
3709           x=cdr(x);
3710
3711           for (; x != sc->NIL; x = cdr(x)) {
3712                if(!comp_func(v,nvalue(car(x)))) {
3713                     s_retbool(0);
3714                }
3715            v=nvalue(car(x));
3716           }
3717           s_retbool(1);
3718      case OP_SYMBOLP:     /* symbol? */
3719           s_retbool(is_symbol(car(sc->args)));
3720      case OP_NUMBERP:     /* number? */
3721           s_retbool(is_number(car(sc->args)));
3722      case OP_STRINGP:     /* string? */
3723           s_retbool(is_string(car(sc->args)));
3724      case OP_INTEGERP:     /* integer? */
3725           s_retbool(is_integer(car(sc->args)));
3726      case OP_REALP:     /* real? */
3727           s_retbool(is_number(car(sc->args))); /* All numbers are real */
3728      case OP_CHARP:     /* char? */
3729           s_retbool(is_character(car(sc->args)));
3730 #if USE_CHAR_CLASSIFIERS
3731      case OP_CHARAP:     /* char-alphabetic? */
3732           s_retbool(Cisalpha(ivalue(car(sc->args))));
3733      case OP_CHARNP:     /* char-numeric? */
3734           s_retbool(Cisdigit(ivalue(car(sc->args))));
3735      case OP_CHARWP:     /* char-whitespace? */
3736           s_retbool(Cisspace(ivalue(car(sc->args))));
3737      case OP_CHARUP:     /* char-upper-case? */
3738           s_retbool(Cisupper(ivalue(car(sc->args))));
3739      case OP_CHARLP:     /* char-lower-case? */
3740           s_retbool(Cislower(ivalue(car(sc->args))));
3741 #endif
3742      case OP_PORTP:     /* port? */
3743           s_retbool(is_port(car(sc->args)));
3744      case OP_INPORTP:     /* input-port? */
3745           s_retbool(is_inport(car(sc->args)));
3746      case OP_OUTPORTP:     /* output-port? */
3747           s_retbool(is_outport(car(sc->args)));
3748      case OP_PROCP:       /* procedure? */
3749           /*--
3750               * continuation should be procedure by the example
3751               * (call-with-current-continuation procedure?) ==> #t
3752                  * in R^3 report sec. 6.9
3753               */
3754           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
3755                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
3756      case OP_PAIRP:       /* pair? */
3757           s_retbool(is_pair(car(sc->args)));
3758      case OP_LISTP:       /* list? */
3759        s_retbool(list_length(sc,car(sc->args)) >= 0);
3760
3761      case OP_ENVP:        /* environment? */
3762           s_retbool(is_environment(car(sc->args)));
3763      case OP_VECTORP:     /* vector? */
3764           s_retbool(is_vector(car(sc->args)));
3765      case OP_EQ:         /* eq? */
3766           s_retbool(car(sc->args) == cadr(sc->args));
3767      case OP_EQV:        /* eqv? */
3768           s_retbool(eqv(car(sc->args), cadr(sc->args)));
3769      default:
3770           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3771           Error_0(sc,sc->strbuff);
3772      }
3773      return sc->T;
3774 }
3775
3776 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
3777      pointer x, y;
3778
3779      switch (op) {
3780      case OP_FORCE:      /* force */
3781           sc->code = car(sc->args);
3782           if (is_promise(sc->code)) {
3783                /* Should change type to closure here */
3784                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3785                sc->args = sc->NIL;
3786                s_goto(sc,OP_APPLY);
3787           } else {
3788                s_return(sc,sc->code);
3789           }
3790
3791      case OP_SAVE_FORCED:     /* Save forced value replacing promise */
3792           memcpy(sc->code,sc->value,sizeof(struct cell));
3793           s_return(sc,sc->value);
3794
3795      case OP_WRITE:      /* write */
3796      case OP_DISPLAY:    /* display */
3797      case OP_WRITE_CHAR: /* write-char */
3798           if(is_pair(cdr(sc->args))) {
3799                if(cadr(sc->args)!=sc->outport) {
3800                     x=cons(sc,sc->outport,sc->NIL);
3801                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3802                     sc->outport=cadr(sc->args);
3803                }
3804           }
3805           sc->args = car(sc->args);
3806           if(op==OP_WRITE) {
3807                sc->print_flag = 1;
3808           } else {
3809                sc->print_flag = 0;
3810           }
3811           s_goto(sc,OP_P0LIST);
3812
3813      case OP_NEWLINE:    /* newline */
3814           if(is_pair(sc->args)) {
3815                if(car(sc->args)!=sc->outport) {
3816                     x=cons(sc,sc->outport,sc->NIL);
3817                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3818                     sc->outport=car(sc->args);
3819                }
3820           }
3821           putstr(sc, "\n");
3822           s_return(sc,sc->T);
3823
3824      case OP_ERR0:  /* error */
3825           sc->retcode=-1;
3826           if (!is_string(car(sc->args))) {
3827                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
3828                setimmutable(car(sc->args));
3829           }
3830           putstr(sc, "Error: ");
3831           putstr(sc, strvalue(car(sc->args)));
3832           sc->args = cdr(sc->args);
3833           s_goto(sc,OP_ERR1);
3834
3835      case OP_ERR1:  /* error */
3836           putstr(sc, " ");
3837           if (sc->args != sc->NIL) {
3838                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
3839                sc->args = car(sc->args);
3840                sc->print_flag = 1;
3841                s_goto(sc,OP_P0LIST);
3842           } else {
3843                putstr(sc, "\n");
3844                if(sc->interactive_repl) {
3845                     s_goto(sc,OP_T0LVL);
3846                } else {
3847                     return sc->NIL;
3848                }
3849           }
3850
3851      case OP_REVERSE:   /* reverse */
3852           s_return(sc,reverse(sc, car(sc->args)));
3853
3854      case OP_LIST_STAR: /* list* */
3855           s_return(sc,list_star(sc,sc->args));
3856
3857      case OP_APPEND:    /* append */
3858           x = sc->NIL;
3859           y = sc->args;
3860           if (y == x) {
3861               s_return(sc, x);
3862           }
3863
3864           /* cdr() in the while condition is not a typo. If car() */
3865           /* is used (append '() 'a) will return the wrong result.*/
3866           while (cdr(y) != sc->NIL) {
3867               x = revappend(sc, x, car(y));
3868               y = cdr(y);
3869               if (x == sc->F) {
3870                   Error_0(sc, "non-list argument to append");
3871               }
3872           }
3873
3874           s_return(sc, reverse_in_place(sc, car(y), x));
3875
3876 #if USE_PLIST
3877      case OP_PUT:        /* put */
3878           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3879                Error_0(sc,"illegal use of put");
3880           }
3881           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3882                if (caar(x) == y) {
3883                     break;
3884                }
3885           }
3886           if (x != sc->NIL)
3887                cdar(x) = caddr(sc->args);
3888           else
3889                symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
3890                                 symprop(car(sc->args)));
3891           s_return(sc,sc->T);
3892
3893      case OP_GET:        /* get */
3894           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3895                Error_0(sc,"illegal use of get");
3896           }
3897           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3898                if (caar(x) == y) {
3899                     break;
3900                }
3901           }
3902           if (x != sc->NIL) {
3903                s_return(sc,cdar(x));
3904           } else {
3905                s_return(sc,sc->NIL);
3906           }
3907 #endif /* USE_PLIST */
3908      case OP_QUIT:       /* quit */
3909           if(is_pair(sc->args)) {
3910                sc->retcode=ivalue(car(sc->args));
3911           }
3912           return (sc->NIL);
3913
3914      case OP_GC:         /* gc */
3915           gc(sc, sc->NIL, sc->NIL);
3916           s_return(sc,sc->T);
3917
3918      case OP_GCVERB:          /* gc-verbose */
3919      {    int  was = sc->gc_verbose;
3920
3921           sc->gc_verbose = (car(sc->args) != sc->F);
3922           s_retbool(was);
3923      }
3924
3925      case OP_NEWSEGMENT: /* new-segment */
3926           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3927                Error_0(sc,"new-segment: argument must be a number");
3928           }
3929           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
3930           s_return(sc,sc->T);
3931
3932      case OP_OBLIST: /* oblist */
3933           s_return(sc, oblist_all_symbols(sc));
3934
3935      case OP_CURR_INPORT: /* current-input-port */
3936           s_return(sc,sc->inport);
3937
3938      case OP_CURR_OUTPORT: /* current-output-port */
3939           s_return(sc,sc->outport);
3940
3941      case OP_OPEN_INFILE: /* open-input-file */
3942      case OP_OPEN_OUTFILE: /* open-output-file */
3943      case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
3944           int prop=0;
3945           pointer p;
3946           switch(op) {
3947                case OP_OPEN_INFILE:     prop=port_input; break;
3948                case OP_OPEN_OUTFILE:    prop=port_output; break;
3949                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
3950                default: assert (! "reached");
3951           }
3952           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
3953           if(p==sc->NIL) {
3954                s_return(sc,sc->F);
3955           }
3956           s_return(sc,p);
3957           break;
3958      default: assert (! "reached");
3959      }
3960
3961 #if USE_STRING_PORTS
3962      case OP_OPEN_INSTRING: /* open-input-string */
3963      case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
3964           int prop=0;
3965           pointer p;
3966           switch(op) {
3967                case OP_OPEN_INSTRING:     prop=port_input; break;
3968                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
3969                default: assert (! "reached");
3970           }
3971           p=port_from_string(sc, strvalue(car(sc->args)),
3972                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
3973           if(p==sc->NIL) {
3974                s_return(sc,sc->F);
3975           }
3976           s_return(sc,p);
3977      }
3978      case OP_OPEN_OUTSTRING: /* open-output-string */ {
3979           pointer p;
3980           if(car(sc->args)==sc->NIL) {
3981                p=port_from_scratch(sc);
3982                if(p==sc->NIL) {
3983                     s_return(sc,sc->F);
3984                }
3985           } else {
3986                p=port_from_string(sc, strvalue(car(sc->args)),
3987                       strvalue(car(sc->args))+strlength(car(sc->args)),
3988                           port_output);
3989                if(p==sc->NIL) {
3990                     s_return(sc,sc->F);
3991                }
3992           }
3993           s_return(sc,p);
3994      }
3995      case OP_GET_OUTSTRING: /* get-output-string */ {
3996           port *p;
3997
3998           if ((p=car(sc->args)->_object._port)->kind&port_string) {
3999                off_t size;
4000                char *str;
4001
4002                size=p->rep.string.curr-p->rep.string.start+1;
4003                str=sc->malloc(size);
4004                if(str != NULL) {
4005                     pointer s;
4006
4007                     memcpy(str,p->rep.string.start,size-1);
4008                     str[size-1]='\0';
4009                     s=mk_string(sc,str);
4010                     sc->free(str);
4011                     s_return(sc,s);
4012                }
4013           }
4014           s_return(sc,sc->F);
4015      }
4016 #endif
4017
4018      case OP_CLOSE_INPORT: /* close-input-port */
4019           port_close(sc,car(sc->args),port_input);
4020           s_return(sc,sc->T);
4021
4022      case OP_CLOSE_OUTPORT: /* close-output-port */
4023           port_close(sc,car(sc->args),port_output);
4024           s_return(sc,sc->T);
4025
4026      case OP_INT_ENV: /* interaction-environment */
4027           s_return(sc,sc->global_env);
4028
4029      case OP_CURR_ENV: /* current-environment */
4030           s_return(sc,sc->envir);
4031
4032      }
4033      return sc->T;
4034 }
4035
4036 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
4037      pointer x;
4038
4039      if(sc->nesting!=0) {
4040           int n=sc->nesting;
4041           sc->nesting=0;
4042           sc->retcode=-1;
4043           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
4044      }
4045
4046      switch (op) {
4047      /* ========== reading part ========== */
4048      case OP_READ:
4049           if(!is_pair(sc->args)) {
4050                s_goto(sc,OP_READ_INTERNAL);
4051           }
4052           if(!is_inport(car(sc->args))) {
4053                Error_1(sc,"read: not an input port:",car(sc->args));
4054           }
4055           if(car(sc->args)==sc->inport) {
4056                s_goto(sc,OP_READ_INTERNAL);
4057           }
4058           x=sc->inport;
4059           sc->inport=car(sc->args);
4060           x=cons(sc,x,sc->NIL);
4061           s_save(sc,OP_SET_INPORT, x, sc->NIL);
4062           s_goto(sc,OP_READ_INTERNAL);
4063
4064      case OP_READ_CHAR: /* read-char */
4065      case OP_PEEK_CHAR: /* peek-char */ {
4066           int c;
4067           if(is_pair(sc->args)) {
4068                if(car(sc->args)!=sc->inport) {
4069                     x=sc->inport;
4070                     x=cons(sc,x,sc->NIL);
4071                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
4072                     sc->inport=car(sc->args);
4073                }
4074           }
4075           c=inchar(sc);
4076           if(c==EOF) {
4077                s_return(sc,sc->EOF_OBJ);
4078           }
4079           if(sc->op==OP_PEEK_CHAR) {
4080                backchar(sc,c);
4081           }
4082           s_return(sc,mk_character(sc,c));
4083      }
4084
4085      case OP_CHAR_READY: /* char-ready? */ {
4086           pointer p=sc->inport;
4087           int res;
4088           if(is_pair(sc->args)) {
4089                p=car(sc->args);
4090           }
4091           res=p->_object._port->kind&port_string;
4092           s_retbool(res);
4093      }
4094
4095      case OP_SET_INPORT: /* set-input-port */
4096           sc->inport=car(sc->args);
4097           s_return(sc,sc->value);
4098
4099      case OP_SET_OUTPORT: /* set-output-port */
4100           sc->outport=car(sc->args);
4101           s_return(sc,sc->value);
4102
4103      case OP_RDSEXPR:
4104           switch (sc->tok) {
4105           case TOK_EOF:
4106                s_return(sc,sc->EOF_OBJ);
4107           /* NOTREACHED */
4108 /*
4109  * Commented out because we now skip comments in the scanner
4110  *
4111           case TOK_COMMENT: {
4112                int c;
4113                while ((c=inchar(sc)) != '\n' && c!=EOF)
4114                     ;
4115                sc->tok = token(sc);
4116                s_goto(sc,OP_RDSEXPR);
4117           }
4118 */
4119           case TOK_VEC:
4120                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
4121                /* fall through */
4122           case TOK_LPAREN:
4123                sc->tok = token(sc);
4124                if (sc->tok == TOK_RPAREN) {
4125                     s_return(sc,sc->NIL);
4126                } else if (sc->tok == TOK_DOT) {
4127                     Error_0(sc,"syntax error: illegal dot expression");
4128                } else {
4129                     sc->nesting_stack[sc->file_i]++;
4130                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
4131                     s_goto(sc,OP_RDSEXPR);
4132                }
4133           case TOK_QUOTE:
4134                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
4135                sc->tok = token(sc);
4136                s_goto(sc,OP_RDSEXPR);
4137           case TOK_BQUOTE:
4138           &nbs