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