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