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