gpgscm: Free memory backing string ports.
[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      char *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 = (char*) 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=(char*)(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 new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1624   char *str=sc->malloc(new_size);
1625   if(str) {
1626     memset(str,' ',new_size-1);
1627     str[new_size-1]='\0';
1628     strcpy(str,start);
1629     p->rep.string.start=str;
1630     p->rep.string.past_the_end=str+new_size-1;
1631     p->rep.string.curr-=start-str;
1632     sc->free(start);
1633     return 1;
1634   } else {
1635     return 0;
1636   }
1637 }
1638
1639 INTERFACE void putstr(scheme *sc, const char *s) {
1640   port *pt=sc->outport->_object._port;
1641   if(pt->kind&port_file) {
1642     fputs(s,pt->rep.stdio.file);
1643   } else {
1644     for(;*s;s++) {
1645       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1646         *pt->rep.string.curr++=*s;
1647       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1648         *pt->rep.string.curr++=*s;
1649       }
1650     }
1651   }
1652 }
1653
1654 static void putchars(scheme *sc, const char *s, int len) {
1655   port *pt=sc->outport->_object._port;
1656   if(pt->kind&port_file) {
1657     fwrite(s,1,len,pt->rep.stdio.file);
1658   } else {
1659     for(;len;len--) {
1660       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1661         *pt->rep.string.curr++=*s++;
1662       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1663         *pt->rep.string.curr++=*s++;
1664       }
1665     }
1666   }
1667 }
1668
1669 INTERFACE void putcharacter(scheme *sc, int c) {
1670   port *pt=sc->outport->_object._port;
1671   if(pt->kind&port_file) {
1672     fputc(c,pt->rep.stdio.file);
1673   } else {
1674     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1675       *pt->rep.string.curr++=c;
1676     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1677         *pt->rep.string.curr++=c;
1678     }
1679   }
1680 }
1681
1682 /* read characters up to delimiter, but cater to character constants */
1683 static char *readstr_upto(scheme *sc, char *delim) {
1684   char *p = sc->strbuff;
1685
1686   while ((p - sc->strbuff < sc->strbuff_size) &&
1687          !is_one_of(delim, (*p++ = inchar(sc))));
1688
1689   if(p == sc->strbuff+2 && p[-2] == '\\') {
1690     *p=0;
1691   } else {
1692     backchar(sc,p[-1]);
1693     *--p = '\0';
1694   }
1695   return sc->strbuff;
1696 }
1697
1698 /* read string expression "xxx...xxx" */
1699 static pointer readstrexp(scheme *sc) {
1700   char *p = sc->strbuff;
1701   int c;
1702   int c1=0;
1703   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1704
1705   for (;;) {
1706     c=inchar(sc);
1707     if(c == EOF) {
1708       return sc->F;
1709     }
1710     if(p-sc->strbuff > (sc->strbuff_size)-1) {
1711       ptrdiff_t offset = p - sc->strbuff;
1712       if (expand_strbuff(sc) != 0) {
1713         return sc->F;
1714       }
1715       p = sc->strbuff + offset;
1716     }
1717     switch(state) {
1718         case st_ok:
1719             switch(c) {
1720                 case '\\':
1721                     state=st_bsl;
1722                     break;
1723                 case '"':
1724                     *p=0;
1725                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1726                 default:
1727                     *p++=c;
1728                     break;
1729             }
1730             break;
1731         case st_bsl:
1732             switch(c) {
1733                 case '0':
1734                 case '1':
1735                 case '2':
1736                 case '3':
1737                 case '4':
1738                 case '5':
1739                 case '6':
1740                 case '7':
1741                         state=st_oct1;
1742                         c1=c-'0';
1743                         break;
1744                 case 'x':
1745                 case 'X':
1746                     state=st_x1;
1747                     c1=0;
1748                     break;
1749                 case 'n':
1750                     *p++='\n';
1751                     state=st_ok;
1752                     break;
1753                 case 't':
1754                     *p++='\t';
1755                     state=st_ok;
1756                     break;
1757                 case 'r':
1758                     *p++='\r';
1759                     state=st_ok;
1760                     break;
1761                 case '"':
1762                     *p++='"';
1763                     state=st_ok;
1764                     break;
1765                 default:
1766                     *p++=c;
1767                     state=st_ok;
1768                     break;
1769             }
1770             break;
1771         case st_x1:
1772         case st_x2:
1773             c=toupper(c);
1774             if(c>='0' && c<='F') {
1775                 if(c<='9') {
1776                     c1=(c1<<4)+c-'0';
1777                 } else {
1778                     c1=(c1<<4)+c-'A'+10;
1779                 }
1780                 if(state==st_x1) {
1781                     state=st_x2;
1782                 } else {
1783                     *p++=c1;
1784                     state=st_ok;
1785                 }
1786             } else {
1787                 return sc->F;
1788             }
1789             break;
1790         case st_oct1:
1791         case st_oct2:
1792             if (c < '0' || c > '7')
1793             {
1794                    *p++=c1;
1795                    backchar(sc, c);
1796                    state=st_ok;
1797             }
1798             else
1799             {
1800                 if (state==st_oct2 && c1 >= 32)
1801                     return sc->F;
1802
1803                    c1=(c1<<3)+(c-'0');
1804
1805                 if (state == st_oct1)
1806                         state=st_oct2;
1807                 else
1808                 {
1809                         *p++=c1;
1810                         state=st_ok;
1811                    }
1812             }
1813             break;
1814
1815     }
1816   }
1817 }
1818
1819 /* check c is in chars */
1820 static INLINE int is_one_of(char *s, int c) {
1821      if(c==EOF) return 1;
1822      while (*s)
1823           if (*s++ == c)
1824                return (1);
1825      return (0);
1826 }
1827
1828 /* skip white characters */
1829 static INLINE int skipspace(scheme *sc) {
1830      int c = 0, curr_line = 0;
1831
1832      do {
1833          c=inchar(sc);
1834 #if SHOW_ERROR_LINE
1835          if(c=='\n')
1836            curr_line++;
1837 #endif
1838      } while (isspace(c));
1839
1840 /* record it */
1841 #if SHOW_ERROR_LINE
1842      if (sc->load_stack[sc->file_i].kind & port_file)
1843        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
1844 #endif
1845
1846      if(c!=EOF) {
1847           backchar(sc,c);
1848       return 1;
1849      }
1850      else
1851        { return EOF; }
1852 }
1853
1854 /* get token */
1855 static int token(scheme *sc) {
1856      int c;
1857      c = skipspace(sc);
1858      if(c == EOF) { return (TOK_EOF); }
1859      switch (c=inchar(sc)) {
1860      case EOF:
1861           return (TOK_EOF);
1862      case '(':
1863           return (TOK_LPAREN);
1864      case ')':
1865           return (TOK_RPAREN);
1866      case '.':
1867           c=inchar(sc);
1868           if(is_one_of(" \n\t",c)) {
1869                return (TOK_DOT);
1870           } else {
1871                backchar(sc,c);
1872                backchar(sc,'.');
1873                return TOK_ATOM;
1874           }
1875      case '\'':
1876           return (TOK_QUOTE);
1877      case ';':
1878            while ((c=inchar(sc)) != '\n' && c!=EOF)
1879              ;
1880
1881 #if SHOW_ERROR_LINE
1882            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1883              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1884 #endif
1885
1886        if(c == EOF)
1887          { return (TOK_EOF); }
1888        else
1889          { return (token(sc));}
1890      case '"':
1891           return (TOK_DQUOTE);
1892      case BACKQUOTE:
1893           return (TOK_BQUOTE);
1894      case ',':
1895          if ((c=inchar(sc)) == '@') {
1896                return (TOK_ATMARK);
1897          } else {
1898                backchar(sc,c);
1899                return (TOK_COMMA);
1900          }
1901      case '#':
1902           c=inchar(sc);
1903           if (c == '(') {
1904                return (TOK_VEC);
1905           } else if(c == '!') {
1906                while ((c=inchar(sc)) != '\n' && c!=EOF)
1907                    ;
1908
1909 #if SHOW_ERROR_LINE
1910            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1911              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1912 #endif
1913
1914            if(c == EOF)
1915              { return (TOK_EOF); }
1916            else
1917              { return (token(sc));}
1918           } else {
1919                backchar(sc,c);
1920                if(is_one_of(" tfodxb\\",c)) {
1921                     return TOK_SHARP_CONST;
1922                } else {
1923                     return (TOK_SHARP);
1924                }
1925           }
1926      default:
1927           backchar(sc,c);
1928           return (TOK_ATOM);
1929      }
1930 }
1931
1932 /* ========== Routines for Printing ========== */
1933 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
1934
1935 static void printslashstring(scheme *sc, char *p, int len) {
1936   int i;
1937   unsigned char *s=(unsigned char*)p;
1938   putcharacter(sc,'"');
1939   for ( i=0; i<len; i++) {
1940     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
1941       putcharacter(sc,'\\');
1942       switch(*s) {
1943       case '"':
1944         putcharacter(sc,'"');
1945         break;
1946       case '\n':
1947         putcharacter(sc,'n');
1948         break;
1949       case '\t':
1950         putcharacter(sc,'t');
1951         break;
1952       case '\r':
1953         putcharacter(sc,'r');
1954         break;
1955       case '\\':
1956         putcharacter(sc,'\\');
1957         break;
1958       default: {
1959           int d=*s/16;
1960           putcharacter(sc,'x');
1961           if(d<10) {
1962             putcharacter(sc,d+'0');
1963           } else {
1964             putcharacter(sc,d-10+'A');
1965           }
1966           d=*s%16;
1967           if(d<10) {
1968             putcharacter(sc,d+'0');
1969           } else {
1970             putcharacter(sc,d-10+'A');
1971           }
1972         }
1973       }
1974     } else {
1975       putcharacter(sc,*s);
1976     }
1977     s++;
1978   }
1979   putcharacter(sc,'"');
1980 }
1981
1982
1983 /* print atoms */
1984 static void printatom(scheme *sc, pointer l, int f) {
1985   char *p;
1986   int len;
1987   atom2str(sc,l,f,&p,&len);
1988   putchars(sc,p,len);
1989 }
1990
1991
1992 /* Uses internal buffer unless string pointer is already available */
1993 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
1994      char *p;
1995
1996      if (l == sc->NIL) {
1997           p = "()";
1998      } else if (l == sc->T) {
1999           p = "#t";
2000      } else if (l == sc->F) {
2001           p = "#f";
2002      } else if (l == sc->EOF_OBJ) {
2003           p = "#<EOF>";
2004      } else if (is_port(l)) {
2005           p = "#<PORT>";
2006      } else if (is_number(l)) {
2007           p = sc->strbuff;
2008           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2009               if(num_is_integer(l)) {
2010                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2011               } else {
2012                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2013                    /* r5rs says there must be a '.' (unless 'e'?) */
2014                    f = strcspn(p, ".e");
2015                    if (p[f] == 0) {
2016                         p[f] = '.'; /* not found, so add '.0' at the end */
2017                         p[f+1] = '0';
2018                         p[f+2] = 0;
2019                    }
2020               }
2021           } else {
2022               long v = ivalue(l);
2023               if (f == 16) {
2024                   if (v >= 0)
2025                     snprintf(p, STRBUFFSIZE, "%lx", v);
2026                   else
2027                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2028               } else if (f == 8) {
2029                   if (v >= 0)
2030                     snprintf(p, STRBUFFSIZE, "%lo", v);
2031                   else
2032                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2033               } else if (f == 2) {
2034                   unsigned long b = (v < 0) ? -v : v;
2035                   p = &p[STRBUFFSIZE-1];
2036                   *p = 0;
2037                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2038                   if (v < 0) *--p = '-';
2039               }
2040           }
2041      } else if (is_string(l)) {
2042           if (!f) {
2043                p = strvalue(l);
2044           } else { /* Hack, uses the fact that printing is needed */
2045                *pp=sc->strbuff;
2046                *plen=0;
2047                printslashstring(sc, strvalue(l), strlength(l));
2048                return;
2049           }
2050      } else if (is_character(l)) {
2051           int c=charvalue(l);
2052           p = sc->strbuff;
2053           if (!f) {
2054                p[0]=c;
2055                p[1]=0;
2056           } else {
2057                switch(c) {
2058                case ' ':
2059                     p = "#\\space";
2060                     break;
2061                case '\n':
2062                     p = "#\\newline";
2063                     break;
2064                case '\r':
2065                     p = "#\\return";
2066                     break;
2067                case '\t':
2068                     p = "#\\tab";
2069                     break;
2070                default:
2071 #if USE_ASCII_NAMES
2072                     if(c==127) {
2073                          p = "#\\del";
2074                          break;
2075                     } else if(c<32) {
2076                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2077                          break;
2078                     }
2079 #else
2080                     if(c<32) {
2081                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2082                       break;
2083                     }
2084 #endif
2085                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2086                     break;
2087                }
2088           }
2089      } else if (is_symbol(l)) {
2090           p = symname(l);
2091      } else if (is_proc(l)) {
2092           p = sc->strbuff;
2093           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2094      } else if (is_macro(l)) {
2095           p = "#<MACRO>";
2096      } else if (is_closure(l)) {
2097           p = "#<CLOSURE>";
2098      } else if (is_promise(l)) {
2099           p = "#<PROMISE>";
2100      } else if (is_foreign(l)) {
2101           p = sc->strbuff;
2102           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2103      } else if (is_continuation(l)) {
2104           p = "#<CONTINUATION>";
2105      } else if (is_foreign_object(l)) {
2106           p = sc->strbuff;
2107           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2108      } else {
2109           p = "#<ERROR>";
2110      }
2111      *pp=p;
2112      *plen=strlen(p);
2113 }
2114 /* ========== Routines for Evaluation Cycle ========== */
2115
2116 /* make closure. c is code. e is environment */
2117 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2118      pointer x = get_cell(sc, c, e);
2119
2120      typeflag(x) = T_CLOSURE;
2121      car(x) = c;
2122      cdr(x) = e;
2123      return (x);
2124 }
2125
2126 /* make continuation. */
2127 static pointer mk_continuation(scheme *sc, pointer d) {
2128      pointer x = get_cell(sc, sc->NIL, d);
2129
2130      typeflag(x) = T_CONTINUATION;
2131      cont_dump(x) = d;
2132      return (x);
2133 }
2134
2135 static pointer list_star(scheme *sc, pointer d) {
2136   pointer p, q;
2137   if(cdr(d)==sc->NIL) {
2138     return car(d);
2139   }
2140   p=cons(sc,car(d),cdr(d));
2141   q=p;
2142   while(cdr(cdr(p))!=sc->NIL) {
2143     d=cons(sc,car(p),cdr(p));
2144     if(cdr(cdr(p))!=sc->NIL) {
2145       p=cdr(d);
2146     }
2147   }
2148   cdr(p)=car(cdr(p));
2149   return q;
2150 }
2151
2152 /* reverse list -- produce new list */
2153 static pointer reverse(scheme *sc, pointer a) {
2154 /* a must be checked by gc */
2155      pointer p = sc->NIL;
2156
2157      for ( ; is_pair(a); a = cdr(a)) {
2158           p = cons(sc, car(a), p);
2159      }
2160      return (p);
2161 }
2162
2163 /* reverse list --- in-place */
2164 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2165      pointer p = list, result = term, q;
2166
2167      while (p != sc->NIL) {
2168           q = cdr(p);
2169           cdr(p) = result;
2170           result = p;
2171           p = q;
2172      }
2173      return (result);
2174 }
2175
2176 /* append list -- produce new list (in reverse order) */
2177 static pointer revappend(scheme *sc, pointer a, pointer b) {
2178     pointer result = a;
2179     pointer p = b;
2180
2181     while (is_pair(p)) {
2182         result = cons(sc, car(p), result);
2183         p = cdr(p);
2184     }
2185
2186     if (p == sc->NIL) {
2187         return result;
2188     }
2189
2190     return sc->F;   /* signal an error */
2191 }
2192
2193 /* equivalence of atoms */
2194 int eqv(pointer a, pointer b) {
2195      if (is_string(a)) {
2196           if (is_string(b))
2197                return (strvalue(a) == strvalue(b));
2198           else
2199                return (0);
2200      } else if (is_number(a)) {
2201           if (is_number(b)) {
2202                if (num_is_integer(a) == num_is_integer(b))
2203                     return num_eq(nvalue(a),nvalue(b));
2204           }
2205           return (0);
2206      } else if (is_character(a)) {
2207           if (is_character(b))
2208                return charvalue(a)==charvalue(b);
2209           else
2210                return (0);
2211      } else if (is_port(a)) {
2212           if (is_port(b))
2213                return a==b;
2214           else
2215                return (0);
2216      } else if (is_proc(a)) {
2217           if (is_proc(b))
2218                return procnum(a)==procnum(b);
2219           else
2220                return (0);
2221      } else {
2222           return (a == b);
2223      }
2224 }
2225
2226 /* true or false value macro */
2227 /* () is #t in R5RS */
2228 #define is_true(p)       ((p) != sc->F)
2229 #define is_false(p)      ((p) == sc->F)
2230
2231 /* ========== Environment implementation  ========== */
2232
2233 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2234
2235 static int hash_fn(const char *key, int table_size)
2236 {
2237   unsigned int hashed = 0;
2238   const char *c;
2239   int bits_per_int = sizeof(unsigned int)*8;
2240
2241   for (c = key; *c; c++) {
2242     /* letters have about 5 bits in them */
2243     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2244     hashed ^= *c;
2245   }
2246   return hashed % table_size;
2247 }
2248 #endif
2249
2250 #ifndef USE_ALIST_ENV
2251
2252 /*
2253  * In this implementation, each frame of the environment may be
2254  * a hash table: a vector of alists hashed by variable name.
2255  * In practice, we use a vector only for the initial frame;
2256  * subsequent frames are too small and transient for the lookup
2257  * speed to out-weigh the cost of making a new vector.
2258  */
2259
2260 static void new_frame_in_env(scheme *sc, pointer old_env)
2261 {
2262   pointer new_frame;
2263
2264   /* The interaction-environment has about 300 variables in it. */
2265   if (old_env == sc->NIL) {
2266     new_frame = mk_vector(sc, 461);
2267   } else {
2268     new_frame = sc->NIL;
2269   }
2270
2271   sc->envir = immutable_cons(sc, new_frame, old_env);
2272   setenvironment(sc->envir);
2273 }
2274
2275 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2276                                         pointer variable, pointer value)
2277 {
2278   pointer slot = immutable_cons(sc, variable, value);
2279
2280   if (is_vector(car(env))) {
2281     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2282
2283     set_vector_elem(car(env), location,
2284                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2285   } else {
2286     car(env) = immutable_cons(sc, slot, car(env));
2287   }
2288 }
2289
2290 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2291 {
2292   pointer x,y;
2293   int location;
2294
2295   for (x = env; x != sc->NIL; x = cdr(x)) {
2296     if (is_vector(car(x))) {
2297       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2298       y = vector_elem(car(x), location);
2299     } else {
2300       y = car(x);
2301     }
2302     for ( ; y != sc->NIL; y = cdr(y)) {
2303               if (caar(y) == hdl) {
2304                    break;
2305               }
2306          }
2307          if (y != sc->NIL) {
2308               break;
2309          }
2310          if(!all) {
2311            return sc->NIL;
2312          }
2313     }
2314     if (x != sc->NIL) {
2315           return car(y);
2316     }
2317     return sc->NIL;
2318 }
2319
2320 #else /* USE_ALIST_ENV */
2321
2322 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2323 {
2324   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2325   setenvironment(sc->envir);
2326 }
2327
2328 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2329                                         pointer variable, pointer value)
2330 {
2331   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2332 }
2333
2334 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2335 {
2336     pointer x,y;
2337     for (x = env; x != sc->NIL; x = cdr(x)) {
2338          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2339               if (caar(y) == hdl) {
2340                    break;
2341               }
2342          }
2343          if (y != sc->NIL) {
2344               break;
2345          }
2346          if(!all) {
2347            return sc->NIL;
2348          }
2349     }
2350     if (x != sc->NIL) {
2351           return car(y);
2352     }
2353     return sc->NIL;
2354 }
2355
2356 #endif /* USE_ALIST_ENV else */
2357
2358 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2359 {
2360   new_slot_spec_in_env(sc, sc->envir, variable, value);
2361 }
2362
2363 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2364 {
2365   (void)sc;
2366   cdr(slot) = value;
2367 }
2368
2369 static INLINE pointer slot_value_in_env(pointer slot)
2370 {
2371   return cdr(slot);
2372 }
2373
2374 /* ========== Evaluation Cycle ========== */
2375
2376
2377 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2378      const char *str = s;
2379 #if USE_ERROR_HOOK
2380      pointer x;
2381      pointer hdl=sc->ERROR_HOOK;
2382 #endif
2383
2384 #if SHOW_ERROR_LINE
2385      char sbuf[STRBUFFSIZE];
2386
2387      /* make sure error is not in REPL */
2388      if (sc->load_stack[sc->file_i].kind & port_file &&
2389          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2390        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2391        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2392
2393        /* should never happen */
2394        if(!fname) fname = "<unknown>";
2395
2396        /* we started from 0 */
2397        ln++;
2398        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2399
2400        str = (const char*)sbuf;
2401      }
2402 #endif
2403
2404 #if USE_ERROR_HOOK
2405      x=find_slot_in_env(sc,sc->envir,hdl,1);
2406     if (x != sc->NIL) {
2407          if(a!=0) {
2408                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2409          } else {
2410                sc->code = sc->NIL;
2411          }
2412          sc->code = cons(sc, mk_string(sc, str), sc->code);
2413          setimmutable(car(sc->code));
2414          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2415          sc->op = (int)OP_EVAL;
2416          return sc->T;
2417     }
2418 #endif
2419
2420     if(a!=0) {
2421           sc->args = cons(sc, (a), sc->NIL);
2422     } else {
2423           sc->args = sc->NIL;
2424     }
2425     sc->args = cons(sc, mk_string(sc, str), sc->args);
2426     setimmutable(car(sc->args));
2427     sc->op = (int)OP_ERR0;
2428     return sc->T;
2429 }
2430 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2431 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2432
2433 /* Too small to turn into function */
2434 # define  BEGIN     do {
2435 # define  END  } while (0)
2436 #define s_goto(sc,a) BEGIN                                  \
2437     sc->op = (int)(a);                                      \
2438     return sc->T; END
2439
2440 #define s_return(sc,a) return _s_return(sc,a)
2441
2442 #ifndef USE_SCHEME_STACK
2443
2444 /* this structure holds all the interpreter's registers */
2445 struct dump_stack_frame {
2446   enum scheme_opcodes op;
2447   pointer args;
2448   pointer envir;
2449   pointer code;
2450 };
2451
2452 #define STACK_GROWTH 3
2453
2454 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
2455 {
2456   int nframes = (int)sc->dump;
2457   struct dump_stack_frame *next_frame;
2458
2459   /* enough room for the next frame? */
2460   if (nframes >= sc->dump_size) {
2461     sc->dump_size += STACK_GROWTH;
2462     /* alas there is no sc->realloc */
2463     sc->dump_base = realloc(sc->dump_base,
2464                             sizeof(struct dump_stack_frame) * sc->dump_size);
2465   }
2466   next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2467   next_frame->op = op;
2468   next_frame->args = args;
2469   next_frame->envir = sc->envir;
2470   next_frame->code = code;
2471   sc->dump = (pointer)(nframes+1);
2472 }
2473
2474 static pointer _s_return(scheme *sc, pointer a)
2475 {
2476   int nframes = (int)sc->dump;
2477   struct dump_stack_frame *frame;
2478
2479   sc->value = (a);
2480   if (nframes <= 0) {
2481     return sc->NIL;
2482   }
2483   nframes--;
2484   frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2485   sc->op = frame->op;
2486   sc->args = frame->args;
2487   sc->envir = frame->envir;
2488   sc->code = frame->code;
2489   sc->dump = (pointer)nframes;
2490   return sc->T;
2491 }
2492
2493 static INLINE void dump_stack_reset(scheme *sc)
2494 {
2495   /* in this implementation, sc->dump is the number of frames on the stack */
2496   sc->dump = (pointer)0;
2497 }
2498
2499 static INLINE void dump_stack_initialize(scheme *sc)
2500 {
2501   sc->dump_size = 0;
2502   sc->dump_base = NULL;
2503   dump_stack_reset(sc);
2504 }
2505
2506 static void dump_stack_free(scheme *sc)
2507 {
2508   free(sc->dump_base);
2509   sc->dump_base = NULL;
2510   sc->dump = (pointer)0;
2511   sc->dump_size = 0;
2512 }
2513
2514 static INLINE void dump_stack_mark(scheme *sc)
2515 {
2516   int nframes = (int)sc->dump;
2517   int i;
2518   for(i=0; i<nframes; i++) {
2519     struct dump_stack_frame *frame;
2520     frame = (struct dump_stack_frame *)sc->dump_base + i;
2521     mark(frame->args);
2522     mark(frame->envir);
2523     mark(frame->code);
2524   }
2525 }
2526
2527 #else
2528
2529 static INLINE void dump_stack_reset(scheme *sc)
2530 {
2531   sc->dump = sc->NIL;
2532 }
2533
2534 static INLINE void dump_stack_initialize(scheme *sc)
2535 {
2536   dump_stack_reset(sc);
2537 }
2538
2539 static void dump_stack_free(scheme *sc)
2540 {
2541   sc->dump = sc->NIL;
2542 }
2543
2544 static pointer _s_return(scheme *sc, pointer a) {
2545     sc->value = (a);
2546     if(sc->dump==sc->NIL) return sc->NIL;
2547     sc->op = ivalue(car(sc->dump));
2548     sc->args = cadr(sc->dump);
2549     sc->envir = caddr(sc->dump);
2550     sc->code = cadddr(sc->dump);
2551     sc->dump = cddddr(sc->dump);
2552     return sc->T;
2553 }
2554
2555 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2556     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2557     sc->dump = cons(sc, (args), sc->dump);
2558     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2559 }
2560
2561 static INLINE void dump_stack_mark(scheme *sc)
2562 {
2563   mark(sc->dump);
2564 }
2565 #endif
2566
2567 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
2568
2569 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2570      pointer x, y;
2571
2572      switch (op) {
2573      case OP_LOAD:       /* load */
2574           if(file_interactive(sc)) {
2575                fprintf(sc->outport->_object._port->rep.stdio.file,
2576                "Loading %s\n", strvalue(car(sc->args)));
2577           }
2578           if (!file_push(sc,strvalue(car(sc->args)))) {
2579                Error_1(sc,"unable to open", car(sc->args));
2580           }
2581       else
2582         {
2583           sc->args = mk_integer(sc,sc->file_i);
2584           s_goto(sc,OP_T0LVL);
2585         }
2586
2587      case OP_T0LVL: /* top level */
2588        /* If we reached the end of file, this loop is done. */
2589        if(sc->loadport->_object._port->kind & port_saw_EOF)
2590      {
2591        if(sc->file_i == 0)
2592          {
2593            sc->args=sc->NIL;
2594            s_goto(sc,OP_QUIT);
2595          }
2596        else
2597          {
2598            file_pop(sc);
2599            s_return(sc,sc->value);
2600          }
2601        /* NOTREACHED */
2602      }
2603
2604        /* If interactive, be nice to user. */
2605        if(file_interactive(sc))
2606      {
2607        sc->envir = sc->global_env;
2608        dump_stack_reset(sc);
2609        putstr(sc,"\n");
2610        putstr(sc,prompt);
2611      }
2612
2613        /* Set up another iteration of REPL */
2614        sc->nesting=0;
2615        sc->save_inport=sc->inport;
2616        sc->inport = sc->loadport;
2617        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2618        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2619        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2620        s_goto(sc,OP_READ_INTERNAL);
2621
2622      case OP_T1LVL: /* top level */
2623           sc->code = sc->value;
2624           sc->inport=sc->save_inport;
2625           s_goto(sc,OP_EVAL);
2626
2627      case OP_READ_INTERNAL:       /* internal read */
2628           sc->tok = token(sc);
2629           if(sc->tok==TOK_EOF)
2630         { s_return(sc,sc->EOF_OBJ); }
2631           s_goto(sc,OP_RDSEXPR);
2632
2633      case OP_GENSYM:
2634           s_return(sc, gensym(sc));
2635
2636      case OP_VALUEPRINT: /* print evaluation result */
2637           /* OP_VALUEPRINT is always pushed, because when changing from
2638              non-interactive to interactive mode, it needs to be
2639              already on the stack */
2640        if(sc->tracing) {
2641          putstr(sc,"\nGives: ");
2642        }
2643        if(file_interactive(sc)) {
2644          sc->print_flag = 1;
2645          sc->args = sc->value;
2646          s_goto(sc,OP_P0LIST);
2647        } else {
2648          s_return(sc,sc->value);
2649        }
2650
2651      case OP_EVAL:       /* main part of evaluation */
2652 #if USE_TRACING
2653        if(sc->tracing) {
2654          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2655          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2656          sc->args=sc->code;
2657          putstr(sc,"\nEval: ");
2658          s_goto(sc,OP_P0LIST);
2659        }
2660        /* fall through */
2661      case OP_REAL_EVAL:
2662 #endif
2663           if (is_symbol(sc->code)) {    /* symbol */
2664                x=find_slot_in_env(sc,sc->envir,sc->code,1);
2665                if (x != sc->NIL) {
2666                     s_return(sc,slot_value_in_env(x));
2667                } else {
2668                     Error_1(sc,"eval: unbound variable:", sc->code);
2669                }
2670           } else if (is_pair(sc->code)) {
2671                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
2672                     sc->code = cdr(sc->code);
2673                     s_goto(sc,syntaxnum(x));
2674                } else {/* first, eval top element and eval arguments */
2675                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2676                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2677                     sc->code = car(sc->code);
2678                     s_goto(sc,OP_EVAL);
2679                }
2680           } else {
2681                s_return(sc,sc->code);
2682           }
2683
2684      case OP_E0ARGS:     /* eval arguments */
2685           if (is_macro(sc->value)) {    /* macro expansion */
2686                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2687                sc->args = cons(sc,sc->code, sc->NIL);
2688                sc->code = sc->value;
2689                s_goto(sc,OP_APPLY);
2690           } else {
2691                sc->code = cdr(sc->code);
2692                s_goto(sc,OP_E1ARGS);
2693           }
2694
2695      case OP_E1ARGS:     /* eval arguments */
2696           sc->args = cons(sc, sc->value, sc->args);
2697           if (is_pair(sc->code)) { /* continue */
2698                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2699                sc->code = car(sc->code);
2700                sc->args = sc->NIL;
2701                s_goto(sc,OP_EVAL);
2702           } else {  /* end */
2703                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2704                sc->code = car(sc->args);
2705                sc->args = cdr(sc->args);
2706                s_goto(sc,OP_APPLY);
2707           }
2708
2709 #if USE_TRACING
2710      case OP_TRACING: {
2711        int tr=sc->tracing;
2712        sc->tracing=ivalue(car(sc->args));
2713        s_return(sc,mk_integer(sc,tr));
2714      }
2715 #endif
2716
2717      case OP_APPLY:      /* apply 'code' to 'args' */
2718 #if USE_TRACING
2719        if(sc->tracing) {
2720          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2721          sc->print_flag = 1;
2722          /*  sc->args=cons(sc,sc->code,sc->args);*/
2723          putstr(sc,"\nApply to: ");
2724          s_goto(sc,OP_P0LIST);
2725        }
2726        /* fall through */
2727      case OP_REAL_APPLY:
2728 #endif
2729           if (is_proc(sc->code)) {
2730                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
2731           } else if (is_foreign(sc->code))
2732             {
2733               /* Keep nested calls from GC'ing the arglist */
2734               push_recent_alloc(sc,sc->args,sc->NIL);
2735                x=sc->code->_object._ff(sc,sc->args);
2736                s_return(sc,x);
2737           } else if (is_closure(sc->code) || is_macro(sc->code)
2738              || is_promise(sc->code)) { /* CLOSURE */
2739         /* Should not accept promise */
2740                /* make environment */
2741                new_frame_in_env(sc, closure_env(sc->code));
2742                for (x = car(closure_code(sc->code)), y = sc->args;
2743                     is_pair(x); x = cdr(x), y = cdr(y)) {
2744                     if (y == sc->NIL) {
2745                          Error_0(sc,"not enough arguments");
2746                     } else {
2747                          new_slot_in_env(sc, car(x), car(y));
2748                     }
2749                }
2750                if (x == sc->NIL) {
2751                     /*--
2752                      * if (y != sc->NIL) {
2753                      *   Error_0(sc,"too many arguments");
2754                      * }
2755                      */
2756                } else if (is_symbol(x))
2757                     new_slot_in_env(sc, x, y);
2758                else {
2759                     Error_1(sc,"syntax error in closure: not a symbol:", x);
2760                }
2761                sc->code = cdr(closure_code(sc->code));
2762                sc->args = sc->NIL;
2763                s_goto(sc,OP_BEGIN);
2764           } else if (is_continuation(sc->code)) { /* CONTINUATION */
2765                sc->dump = cont_dump(sc->code);
2766                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2767           } else {
2768                Error_1(sc,"illegal function",sc->code);
2769           }
2770
2771      case OP_DOMACRO:    /* do macro */
2772           sc->code = sc->value;
2773           s_goto(sc,OP_EVAL);
2774
2775 #if 1
2776      case OP_LAMBDA:     /* lambda */
2777           /* If the hook is defined, apply it to sc->code, otherwise
2778              set sc->value fall thru */
2779           {
2780                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2781                if(f==sc->NIL) {
2782                     sc->value = sc->code;
2783                     /* Fallthru */
2784                } else {
2785                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2786                     sc->args=cons(sc,sc->code,sc->NIL);
2787                     sc->code=slot_value_in_env(f);
2788                     s_goto(sc,OP_APPLY);
2789                }
2790           }
2791
2792      case OP_LAMBDA1:
2793           s_return(sc,mk_closure(sc, sc->value, sc->envir));
2794
2795 #else
2796      case OP_LAMBDA:     /* lambda */
2797           s_return(sc,mk_closure(sc, sc->code, sc->envir));
2798
2799 #endif
2800
2801      case OP_MKCLOSURE: /* make-closure */
2802        x=car(sc->args);
2803        if(car(x)==sc->LAMBDA) {
2804          x=cdr(x);
2805        }
2806        if(cdr(sc->args)==sc->NIL) {
2807          y=sc->envir;
2808        } else {
2809          y=cadr(sc->args);
2810        }
2811        s_return(sc,mk_closure(sc, x, y));
2812
2813      case OP_QUOTE:      /* quote */
2814           s_return(sc,car(sc->code));
2815
2816      case OP_DEF0:  /* define */
2817           if(is_immutable(car(sc->code)))
2818             Error_1(sc,"define: unable to alter immutable", car(sc->code));
2819
2820           if (is_pair(car(sc->code))) {
2821                x = caar(sc->code);
2822                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2823           } else {
2824                x = car(sc->code);
2825                sc->code = cadr(sc->code);
2826           }
2827           if (!is_symbol(x)) {
2828                Error_0(sc,"variable is not a symbol");
2829           }
2830           s_save(sc,OP_DEF1, sc->NIL, x);
2831           s_goto(sc,OP_EVAL);
2832
2833      case OP_DEF1:  /* define */
2834           x=find_slot_in_env(sc,sc->envir,sc->code,0);
2835           if (x != sc->NIL) {
2836                set_slot_in_env(sc, x, sc->value);
2837           } else {
2838                new_slot_in_env(sc, sc->code, sc->value);
2839           }
2840           s_return(sc,sc->code);
2841
2842
2843      case OP_DEFP:  /* defined? */
2844           x=sc->envir;
2845           if(cdr(sc->args)!=sc->NIL) {
2846                x=cadr(sc->args);
2847           }
2848           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2849
2850      case OP_SET0:       /* set! */
2851           if(is_immutable(car(sc->code)))
2852                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
2853           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2854           sc->code = cadr(sc->code);
2855           s_goto(sc,OP_EVAL);
2856
2857      case OP_SET1:       /* set! */
2858           y=find_slot_in_env(sc,sc->envir,sc->code,1);
2859           if (y != sc->NIL) {
2860                set_slot_in_env(sc, y, sc->value);
2861                s_return(sc,sc->value);
2862           } else {
2863                Error_1(sc,"set!: unbound variable:", sc->code);
2864           }
2865
2866
2867      case OP_BEGIN:      /* begin */
2868           if (!is_pair(sc->code)) {
2869                s_return(sc,sc->code);
2870           }
2871           if (cdr(sc->code) != sc->NIL) {
2872                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2873           }
2874           sc->code = car(sc->code);
2875           s_goto(sc,OP_EVAL);
2876
2877      case OP_IF0:        /* if */
2878           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2879           sc->code = car(sc->code);
2880           s_goto(sc,OP_EVAL);
2881
2882      case OP_IF1:        /* if */
2883           if (is_true(sc->value))
2884                sc->code = car(sc->code);
2885           else
2886                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
2887                                             * car(sc->NIL) = sc->NIL */
2888           s_goto(sc,OP_EVAL);
2889
2890      case OP_LET0:       /* let */
2891           sc->args = sc->NIL;
2892           sc->value = sc->code;
2893           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2894           s_goto(sc,OP_LET1);
2895
2896      case OP_LET1:       /* let (calculate parameters) */
2897           sc->args = cons(sc, sc->value, sc->args);
2898           if (is_pair(sc->code)) { /* continue */
2899                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2900                     Error_1(sc, "Bad syntax of binding spec in let :",
2901                             car(sc->code));
2902                }
2903                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2904                sc->code = cadar(sc->code);
2905                sc->args = sc->NIL;
2906                s_goto(sc,OP_EVAL);
2907           } else {  /* end */
2908                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2909                sc->code = car(sc->args);
2910                sc->args = cdr(sc->args);
2911                s_goto(sc,OP_LET2);
2912           }
2913
2914      case OP_LET2:       /* let */
2915           new_frame_in_env(sc, sc->envir);
2916           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2917                y != sc->NIL; x = cdr(x), y = cdr(y)) {
2918                new_slot_in_env(sc, caar(x), car(y));
2919           }
2920           if (is_symbol(car(sc->code))) {    /* named let */
2921                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2922                     if (!is_pair(x))
2923                         Error_1(sc, "Bad syntax of binding in let :", x);
2924                     if (!is_list(sc, car(x)))
2925                         Error_1(sc, "Bad syntax of binding in let :", car(x));
2926                     sc->args = cons(sc, caar(x), sc->args);
2927                }
2928                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2929                new_slot_in_env(sc, car(sc->code), x);
2930                sc->code = cddr(sc->code);
2931                sc->args = sc->NIL;
2932           } else {
2933                sc->code = cdr(sc->code);
2934                sc->args = sc->NIL;
2935           }
2936           s_goto(sc,OP_BEGIN);
2937
2938      case OP_LET0AST:    /* let* */
2939           if (car(sc->code) == sc->NIL) {
2940                new_frame_in_env(sc, sc->envir);
2941                sc->code = cdr(sc->code);
2942                s_goto(sc,OP_BEGIN);
2943           }
2944           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
2945                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
2946           }
2947           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2948           sc->code = cadaar(sc->code);
2949           s_goto(sc,OP_EVAL);
2950
2951      case OP_LET1AST:    /* let* (make new frame) */
2952           new_frame_in_env(sc, sc->envir);
2953           s_goto(sc,OP_LET2AST);
2954
2955      case OP_LET2AST:    /* let* (calculate parameters) */
2956           new_slot_in_env(sc, caar(sc->code), sc->value);
2957           sc->code = cdr(sc->code);
2958           if (is_pair(sc->code)) { /* continue */
2959                s_save(sc,OP_LET2AST, sc->args, sc->code);
2960                sc->code = cadar(sc->code);
2961                sc->args = sc->NIL;
2962                s_goto(sc,OP_EVAL);
2963           } else {  /* end */
2964                sc->code = sc->args;
2965                sc->args = sc->NIL;
2966                s_goto(sc,OP_BEGIN);
2967           }
2968      default:
2969           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
2970           Error_0(sc,sc->strbuff);
2971      }
2972      return sc->T;
2973 }
2974
2975 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2976      pointer x, y;
2977
2978      switch (op) {
2979      case OP_LET0REC:    /* letrec */
2980           new_frame_in_env(sc, sc->envir);
2981           sc->args = sc->NIL;
2982           sc->value = sc->code;
2983           sc->code = car(sc->code);
2984           s_goto(sc,OP_LET1REC);
2985
2986      case OP_LET1REC:    /* letrec (calculate parameters) */
2987           sc->args = cons(sc, sc->value, sc->args);
2988           if (is_pair(sc->code)) { /* continue */
2989                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2990                     Error_1(sc, "Bad syntax of binding spec in letrec :",
2991                             car(sc->code));
2992                }
2993                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2994                sc->code = cadar(sc->code);
2995                sc->args = sc->NIL;
2996                s_goto(sc,OP_EVAL);
2997           } else {  /* end */
2998                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2999                sc->code = car(sc->args);
3000                sc->args = cdr(sc->args);
3001                s_goto(sc,OP_LET2REC);
3002           }
3003
3004      case OP_LET2REC:    /* letrec */
3005           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
3006                new_slot_in_env(sc, caar(x), car(y));
3007           }
3008           sc->code = cdr(sc->code);
3009           sc->args = sc->NIL;
3010           s_goto(sc,OP_BEGIN);
3011
3012      case OP_COND0:      /* cond */
3013           if (!is_pair(sc->code)) {
3014                Error_0(sc,"syntax error in cond");
3015           }
3016           s_save(sc,OP_COND1, sc->NIL, sc->code);
3017           sc->code = caar(sc->code);
3018           s_goto(sc,OP_EVAL);
3019
3020      case OP_COND1:      /* cond */
3021           if (is_true(sc->value)) {
3022                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3023                     s_return(sc,sc->value);
3024                }
3025                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3026                     if(!is_pair(cdr(sc->code))) {
3027                          Error_0(sc,"syntax error in cond");
3028                     }
3029                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3030                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3031                     s_goto(sc,OP_EVAL);
3032                }
3033                s_goto(sc,OP_BEGIN);
3034           } else {
3035                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3036                     s_return(sc,sc->NIL);
3037                } else {
3038                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3039                     sc->code = caar(sc->code);
3040                     s_goto(sc,OP_EVAL);
3041                }
3042           }
3043
3044      case OP_DELAY:      /* delay */
3045           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3046           typeflag(x)=T_PROMISE;
3047           s_return(sc,x);
3048
3049      case OP_AND0:       /* and */
3050           if (sc->code == sc->NIL) {
3051                s_return(sc,sc->T);
3052           }
3053           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3054           sc->code = car(sc->code);
3055           s_goto(sc,OP_EVAL);
3056
3057      case OP_AND1:       /* and */
3058           if (is_false(sc->value)) {
3059                s_return(sc,sc->value);
3060           } else if (sc->code == sc->NIL) {
3061                s_return(sc,sc->value);
3062           } else {
3063                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3064                sc->code = car(sc->code);
3065                s_goto(sc,OP_EVAL);
3066           }
3067
3068      case OP_OR0:        /* or */
3069           if (sc->code == sc->NIL) {
3070                s_return(sc,sc->F);
3071           }
3072           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3073           sc->code = car(sc->code);
3074           s_goto(sc,OP_EVAL);
3075
3076      case OP_OR1:        /* or */
3077           if (is_true(sc->value)) {
3078                s_return(sc,sc->value);
3079           } else if (sc->code == sc->NIL) {
3080                s_return(sc,sc->value);
3081           } else {
3082                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3083                sc->code = car(sc->code);
3084                s_goto(sc,OP_EVAL);
3085           }
3086
3087      case OP_C0STREAM:   /* cons-stream */
3088           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3089           sc->code = car(sc->code);
3090           s_goto(sc,OP_EVAL);
3091
3092      case OP_C1STREAM:   /* cons-stream */
3093           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3094           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3095           typeflag(x)=T_PROMISE;
3096           s_return(sc,cons(sc, sc->args, x));
3097
3098      case OP_MACRO0:     /* macro */
3099           if (is_pair(car(sc->code))) {
3100                x = caar(sc->code);
3101                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3102           } else {
3103                x = car(sc->code);
3104                sc->code = cadr(sc->code);
3105           }
3106           if (!is_symbol(x)) {
3107                Error_0(sc,"variable is not a symbol");
3108           }
3109           s_save(sc,OP_MACRO1, sc->NIL, x);
3110           s_goto(sc,OP_EVAL);
3111
3112      case OP_MACRO1:     /* macro */
3113           typeflag(sc->value) = T_MACRO;
3114           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3115           if (x != sc->NIL) {
3116                set_slot_in_env(sc, x, sc->value);
3117           } else {
3118                new_slot_in_env(sc, sc->code, sc->value);
3119           }
3120           s_return(sc,sc->code);
3121
3122      case OP_CASE0:      /* case */
3123           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3124           sc->code = car(sc->code);
3125           s_goto(sc,OP_EVAL);
3126
3127      case OP_CASE1:      /* case */
3128           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3129                if (!is_pair(y = caar(x))) {
3130                     break;
3131                }
3132                for ( ; y != sc->NIL; y = cdr(y)) {
3133                     if (eqv(car(y), sc->value)) {
3134                          break;
3135                     }
3136                }
3137                if (y != sc->NIL) {
3138                     break;
3139                }
3140           }
3141           if (x != sc->NIL) {
3142                if (is_pair(caar(x))) {
3143                     sc->code = cdar(x);
3144                     s_goto(sc,OP_BEGIN);
3145                } else {/* else */
3146                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3147                     sc->code = caar(x);
3148                     s_goto(sc,OP_EVAL);
3149                }
3150           } else {
3151                s_return(sc,sc->NIL);
3152           }
3153
3154      case OP_CASE2:      /* case */
3155           if (is_true(sc->value)) {
3156                s_goto(sc,OP_BEGIN);
3157           } else {
3158                s_return(sc,sc->NIL);
3159           }
3160
3161      case OP_PAPPLY:     /* apply */
3162           sc->code = car(sc->args);
3163           sc->args = list_star(sc,cdr(sc->args));
3164           /*sc->args = cadr(sc->args);*/
3165           s_goto(sc,OP_APPLY);
3166
3167      case OP_PEVAL: /* eval */
3168           if(cdr(sc->args)!=sc->NIL) {
3169                sc->envir=cadr(sc->args);
3170           }
3171           sc->code = car(sc->args);
3172           s_goto(sc,OP_EVAL);
3173
3174      case OP_CONTINUATION:    /* call-with-current-continuation */
3175           sc->code = car(sc->args);
3176           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3177           s_goto(sc,OP_APPLY);
3178
3179      default:
3180           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3181           Error_0(sc,sc->strbuff);
3182      }
3183      return sc->T;
3184 }
3185
3186 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3187      pointer x;
3188      num v;
3189 #if USE_MATH
3190      double dd;
3191 #endif
3192
3193      switch (op) {
3194 #if USE_MATH
3195      case OP_INEX2EX:    /* inexact->exact */
3196           x=car(sc->args);
3197           if(num_is_integer(x)) {
3198                s_return(sc,x);
3199           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3200                s_return(sc,mk_integer(sc,ivalue(x)));
3201           } else {
3202                Error_1(sc,"inexact->exact: not integral:",x);
3203           }
3204
3205      case OP_EXP:
3206           x=car(sc->args);
3207           s_return(sc, mk_real(sc, exp(rvalue(x))));
3208
3209      case OP_LOG:
3210           x=car(sc->args);
3211           s_return(sc, mk_real(sc, log(rvalue(x))));
3212
3213      case OP_SIN:
3214           x=car(sc->args);
3215           s_return(sc, mk_real(sc, sin(rvalue(x))));
3216
3217      case OP_COS:
3218           x=car(sc->args);
3219           s_return(sc, mk_real(sc, cos(rvalue(x))));
3220
3221      case OP_TAN:
3222           x=car(sc->args);
3223           s_return(sc, mk_real(sc, tan(rvalue(x))));
3224
3225      case OP_ASIN:
3226           x=car(sc->args);
3227           s_return(sc, mk_real(sc, asin(rvalue(x))));
3228
3229      case OP_ACOS:
3230           x=car(sc->args);
3231           s_return(sc, mk_real(sc, acos(rvalue(x))));
3232
3233      case OP_ATAN:
3234           x=car(sc->args);
3235           if(cdr(sc->args)==sc->NIL) {
3236                s_return(sc, mk_real(sc, atan(rvalue(x))));
3237           } else {
3238                pointer y=cadr(sc->args);
3239                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3240           }
3241
3242      case OP_SQRT:
3243           x=car(sc->args);
3244           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3245
3246      case OP_EXPT: {
3247           double result;
3248           int real_result=1;
3249           pointer y=cadr(sc->args);
3250           x=car(sc->args);
3251           if (num_is_integer(x) && num_is_integer(y))
3252              real_result=0;
3253           /* This 'if' is an R5RS compatibility fix. */
3254           /* NOTE: Remove this 'if' fix for R6RS.    */
3255           if (rvalue(x) == 0 && rvalue(y) < 0) {
3256              result = 0.0;
3257           } else {
3258              result = pow(rvalue(x),rvalue(y));
3259           }
3260           /* Before returning integer result make sure we can. */
3261           /* If the test fails, result is too big for integer. */
3262           if (!real_result)
3263           {
3264             long result_as_long = (long)result;
3265             if (result != (double)result_as_long)
3266               real_result = 1;
3267           }
3268           if (real_result) {
3269              s_return(sc, mk_real(sc, result));
3270           } else {
3271              s_return(sc, mk_integer(sc, result));
3272           }
3273      }
3274
3275      case OP_FLOOR:
3276           x=car(sc->args);
3277           s_return(sc, mk_real(sc, floor(rvalue(x))));
3278
3279      case OP_CEILING:
3280           x=car(sc->args);
3281           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3282
3283      case OP_TRUNCATE : {
3284           double rvalue_of_x ;
3285           x=car(sc->args);
3286           rvalue_of_x = rvalue(x) ;
3287           if (rvalue_of_x > 0) {
3288             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3289           } else {
3290             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3291           }
3292      }
3293
3294      case OP_ROUND:
3295         x=car(sc->args);
3296         if (num_is_integer(x))
3297             s_return(sc, x);
3298         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3299 #endif
3300
3301      case OP_ADD:        /* + */
3302        v=num_zero;
3303        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3304          v=num_add(v,nvalue(car(x)));
3305        }
3306        s_return(sc,mk_number(sc, v));
3307
3308      case OP_MUL:        /* * */
3309        v=num_one;
3310        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3311          v=num_mul(v,nvalue(car(x)));
3312        }
3313        s_return(sc,mk_number(sc, v));
3314
3315      case OP_SUB:        /* - */
3316        if(cdr(sc->args)==sc->NIL) {
3317          x=sc->args;
3318          v=num_zero;
3319        } else {
3320          x = cdr(sc->args);
3321          v = nvalue(car(sc->args));
3322        }
3323        for (; x != sc->NIL; x = cdr(x)) {
3324          v=num_sub(v,nvalue(car(x)));
3325        }
3326        s_return(sc,mk_number(sc, v));
3327
3328      case OP_DIV:        /* / */
3329        if(cdr(sc->args)==sc->NIL) {
3330          x=sc->args;
3331          v=num_one;
3332        } else {
3333          x = cdr(sc->args);
3334          v = nvalue(car(sc->args));
3335        }
3336        for (; x != sc->NIL; x = cdr(x)) {
3337          if (!is_zero_double(rvalue(car(x))))
3338            v=num_div(v,nvalue(car(x)));
3339          else {
3340            Error_0(sc,"/: division by zero");
3341          }
3342        }
3343        s_return(sc,mk_number(sc, v));
3344
3345      case OP_INTDIV:        /* quotient */
3346           if(cdr(sc->args)==sc->NIL) {
3347                x=sc->args;
3348                v=num_one;
3349           } else {
3350                x = cdr(sc->args);
3351                v = nvalue(car(sc->args));
3352           }
3353           for (; x != sc->NIL; x = cdr(x)) {
3354                if (ivalue(car(x)) != 0)
3355                     v=num_intdiv(v,nvalue(car(x)));
3356                else {
3357                     Error_0(sc,"quotient: division by zero");
3358                }
3359           }
3360           s_return(sc,mk_number(sc, v));
3361
3362      case OP_REM:        /* remainder */
3363           v = nvalue(car(sc->args));
3364           if (ivalue(cadr(sc->args)) != 0)
3365                v=num_rem(v,nvalue(cadr(sc->args)));
3366           else {
3367                Error_0(sc,"remainder: division by zero");
3368           }
3369           s_return(sc,mk_number(sc, v));
3370
3371      case OP_MOD:        /* modulo */
3372           v = nvalue(car(sc->args));
3373           if (ivalue(cadr(sc->args)) != 0)
3374                v=num_mod(v,nvalue(cadr(sc->args)));
3375           else {
3376                Error_0(sc,"modulo: division by zero");
3377           }
3378           s_return(sc,mk_number(sc, v));
3379
3380      case OP_CAR:        /* car */
3381           s_return(sc,caar(sc->args));
3382
3383      case OP_CDR:        /* cdr */
3384           s_return(sc,cdar(sc->args));
3385
3386      case OP_CONS:       /* cons */
3387           cdr(sc->args) = cadr(sc->args);
3388           s_return(sc,sc->args);
3389
3390      case OP_SETCAR:     /* set-car! */
3391        if(!is_immutable(car(sc->args))) {
3392          caar(sc->args) = cadr(sc->args);
3393          s_return(sc,car(sc->args));
3394        } else {
3395          Error_0(sc,"set-car!: unable to alter immutable pair");
3396        }
3397
3398      case OP_SETCDR:     /* set-cdr! */
3399        if(!is_immutable(car(sc->args))) {
3400          cdar(sc->args) = cadr(sc->args);
3401          s_return(sc,car(sc->args));
3402        } else {
3403          Error_0(sc,"set-cdr!: unable to alter immutable pair");
3404        }
3405
3406      case OP_CHAR2INT: { /* char->integer */
3407           char c;
3408           c=(char)ivalue(car(sc->args));
3409           s_return(sc,mk_integer(sc,(unsigned char)c));
3410      }
3411
3412      case OP_INT2CHAR: { /* integer->char */
3413           unsigned char c;
3414           c=(unsigned char)ivalue(car(sc->args));
3415           s_return(sc,mk_character(sc,(char)c));
3416      }
3417
3418      case OP_CHARUPCASE: {
3419           unsigned char c;
3420           c=(unsigned char)ivalue(car(sc->args));
3421           c=toupper(c);
3422           s_return(sc,mk_character(sc,(char)c));
3423      }
3424
3425      case OP_CHARDNCASE: {
3426           unsigned char c;
3427           c=(unsigned char)ivalue(car(sc->args));
3428           c=tolower(c);
3429           s_return(sc,mk_character(sc,(char)c));
3430      }
3431
3432      case OP_STR2SYM:  /* string->symbol */
3433           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3434
3435      case OP_STR2ATOM: /* string->atom */ {
3436           char *s=strvalue(car(sc->args));
3437           long pf = 0;
3438           if(cdr(sc->args)!=sc->NIL) {
3439             /* we know cadr(sc->args) is a natural number */
3440             /* see if it is 2, 8, 10, or 16, or error */
3441             pf = ivalue_unchecked(cadr(sc->args));
3442             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3443                /* base is OK */
3444             }
3445             else {
3446               pf = -1;
3447             }
3448           }
3449           if (pf < 0) {
3450             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3451           } else if(*s=='#') /* no use of base! */ {
3452             s_return(sc, mk_sharp_const(sc, s+1));
3453           } else {
3454             if (pf == 0 || pf == 10) {
3455               s_return(sc, mk_atom(sc, s));
3456             }
3457             else {
3458               char *ep;
3459               long iv = strtol(s,&ep,(int )pf);
3460               if (*ep == 0) {
3461                 s_return(sc, mk_integer(sc, iv));
3462               }
3463               else {
3464                 s_return(sc, sc->F);
3465               }
3466             }
3467           }
3468         }
3469
3470      case OP_SYM2STR: /* symbol->string */
3471           x=mk_string(sc,symname(car(sc->args)));
3472           setimmutable(x);
3473           s_return(sc,x);
3474
3475      case OP_ATOM2STR: /* atom->string */ {
3476           long pf = 0;
3477           x=car(sc->args);
3478           if(cdr(sc->args)!=sc->NIL) {
3479             /* we know cadr(sc->args) is a natural number */
3480             /* see if it is 2, 8, 10, or 16, or error */
3481             pf = ivalue_unchecked(cadr(sc->args));
3482             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
3483               /* base is OK */
3484             }
3485             else {
3486               pf = -1;
3487             }
3488           }
3489           if (pf < 0) {
3490             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
3491           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3492             char *p;
3493             int len;
3494             atom2str(sc,x,(int )pf,&p,&len);
3495             s_return(sc,mk_counted_string(sc,p,len));
3496           } else {
3497             Error_1(sc, "atom->string: not an atom:", x);
3498           }
3499         }
3500
3501      case OP_MKSTRING: { /* make-string */
3502           int fill=' ';
3503           int len;
3504
3505           len=ivalue(car(sc->args));
3506
3507           if(cdr(sc->args)!=sc->NIL) {
3508                fill=charvalue(cadr(sc->args));
3509           }
3510           s_return(sc,mk_empty_string(sc,len,(char)fill));
3511      }
3512
3513      case OP_STRLEN:  /* string-length */
3514           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
3515
3516      case OP_STRREF: { /* string-ref */
3517           char *str;
3518           int index;
3519
3520           str=strvalue(car(sc->args));
3521
3522           index=ivalue(cadr(sc->args));
3523
3524           if(index>=strlength(car(sc->args))) {
3525                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3526           }
3527
3528           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
3529      }
3530
3531      case OP_STRSET: { /* string-set! */
3532           char *str;
3533           int index;
3534           int c;
3535
3536           if(is_immutable(car(sc->args))) {
3537                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3538           }
3539           str=strvalue(car(sc->args));
3540
3541           index=ivalue(cadr(sc->args));
3542           if(index>=strlength(car(sc->args))) {
3543                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3544           }
3545
3546           c=charvalue(caddr(sc->args));
3547
3548           str[index]=(char)c;
3549           s_return(sc,car(sc->args));
3550      }
3551
3552      case OP_STRAPPEND: { /* string-append */
3553        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3554        int len = 0;
3555        pointer newstr;
3556        char *pos;
3557
3558        /* compute needed length for new string */
3559        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3560           len += strlength(car(x));
3561        }
3562        newstr = mk_empty_string(sc, len, ' ');
3563        /* store the contents of the argument strings into the new string */
3564        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3565            pos += strlength(car(x)), x = cdr(x)) {
3566            memcpy(pos, strvalue(car(x)), strlength(car(x)));
3567        }
3568        s_return(sc, newstr);
3569      }
3570
3571      case OP_SUBSTR: { /* substring */
3572           char *str;
3573           int index0;
3574           int index1;
3575           int len;
3576
3577           str=strvalue(car(sc->args));
3578
3579           index0=ivalue(cadr(sc->args));
3580
3581           if(index0>strlength(car(sc->args))) {
3582                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3583           }
3584
3585           if(cddr(sc->args)!=sc->NIL) {
3586                index1=ivalue(caddr(sc->args));
3587                if(index1>strlength(car(sc->args)) || index1<index0) {
3588                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
3589                }
3590           } else {
3591                index1=strlength(car(sc->args));
3592           }
3593
3594           len=index1-index0;
3595           x=mk_empty_string(sc,len,' ');
3596           memcpy(strvalue(x),str+index0,len);
3597           strvalue(x)[len]=0;
3598
3599           s_return(sc,x);
3600      }
3601
3602      case OP_VECTOR: {   /* vector */
3603           int i;
3604           pointer vec;
3605           int len=list_length(sc,sc->args);
3606           if(len<0) {
3607                Error_1(sc,"vector: not a proper list:",sc->args);
3608           }
3609           vec=mk_vector(sc,len);
3610           if(sc->no_memory) { s_return(sc, sc->sink); }
3611           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3612                set_vector_elem(vec,i,car(x));
3613           }
3614           s_return(sc,vec);
3615      }
3616
3617      case OP_MKVECTOR: { /* make-vector */
3618           pointer fill=sc->NIL;
3619           int len;
3620           pointer vec;
3621
3622           len=ivalue(car(sc->args));
3623
3624           if(cdr(sc->args)!=sc->NIL) {
3625                fill=cadr(sc->args);
3626           }
3627           vec=mk_vector(sc,len);
3628           if(sc->no_memory) { s_return(sc, sc->sink); }
3629           if(fill!=sc->NIL) {
3630                fill_vector(vec,fill);
3631           }
3632           s_return(sc,vec);
3633      }
3634
3635      case OP_VECLEN:  /* vector-length */
3636           s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
3637
3638      case OP_VECREF: { /* vector-ref */
3639           int index;
3640
3641           index=ivalue(cadr(sc->args));
3642
3643           if(index>=ivalue(car(sc->args))) {
3644                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
3645           }
3646
3647           s_return(sc,vector_elem(car(sc->args),index));
3648      }
3649
3650      case OP_VECSET: {   /* vector-set! */
3651           int index;
3652
3653           if(is_immutable(car(sc->args))) {
3654                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
3655           }
3656
3657           index=ivalue(cadr(sc->args));
3658           if(index>=ivalue(car(sc->args))) {
3659                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
3660           }
3661
3662           set_vector_elem(car(sc->args),index,caddr(sc->args));
3663           s_return(sc,car(sc->args));
3664      }
3665
3666      default:
3667           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3668           Error_0(sc,sc->strbuff);
3669      }
3670      return sc->T;
3671 }
3672
3673 static int is_list(scheme *sc, pointer a)
3674 { return list_length(sc,a) >= 0; }
3675
3676 /* Result is:
3677    proper list: length
3678    circular list: -1
3679    not even a pair: -2
3680    dotted list: -2 minus length before dot
3681 */
3682 int list_length(scheme *sc, pointer a) {
3683     int i=0;
3684     pointer slow, fast;
3685
3686     slow = fast = a;
3687     while (1)
3688     {
3689         if (fast == sc->NIL)
3690                 return i;
3691         if (!is_pair(fast))
3692                 return -2 - i;
3693         fast = cdr(fast);
3694         ++i;
3695         if (fast == sc->NIL)
3696                 return i;
3697         if (!is_pair(fast))
3698                 return -2 - i;
3699         ++i;
3700         fast = cdr(fast);
3701
3702         /* Safe because we would have already returned if `fast'
3703            encountered a non-pair. */
3704         slow = cdr(slow);
3705         if (fast == slow)
3706         {
3707             /* the fast pointer has looped back around and caught up
3708                with the slow pointer, hence the structure is circular,
3709                not of finite length, and therefore not a list */
3710             return -1;
3711         }
3712     }
3713 }
3714
3715 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
3716      pointer x;
3717      num v;
3718      int (*comp_func)(num,num)=0;
3719
3720      switch (op) {
3721      case OP_NOT:        /* not */
3722           s_retbool(is_false(car(sc->args)));
3723      case OP_BOOLP:       /* boolean? */
3724           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3725      case OP_EOFOBJP:       /* boolean? */
3726           s_retbool(car(sc->args) == sc->EOF_OBJ);
3727      case OP_NULLP:       /* null? */
3728           s_retbool(car(sc->args) == sc->NIL);
3729      case OP_NUMEQ:      /* = */
3730      case OP_LESS:       /* < */
3731      case OP_GRE:        /* > */
3732      case OP_LEQ:        /* <= */
3733      case OP_GEQ:        /* >= */
3734           switch(op) {
3735                case OP_NUMEQ: comp_func=num_eq; break;
3736                case OP_LESS:  comp_func=num_lt; break;
3737                case OP_GRE:   comp_func=num_gt; break;
3738                case OP_LEQ:   comp_func=num_le; break;
3739                case OP_GEQ:   comp_func=num_ge; break;
3740                default: assert (! "reached");
3741           }
3742           x=sc->args;
3743           v=nvalue(car(x));
3744           x=cdr(x);
3745
3746           for (; x != sc->NIL; x = cdr(x)) {
3747                if(!comp_func(v,nvalue(car(x)))) {
3748                     s_retbool(0);
3749                }
3750            v=nvalue(car(x));
3751           }
3752           s_retbool(1);
3753      case OP_SYMBOLP:     /* symbol? */
3754           s_retbool(is_symbol(car(sc->args)));
3755      case OP_NUMBERP:     /* number? */
3756           s_retbool(is_number(car(sc->args)));
3757      case OP_STRINGP:     /* string? */
3758           s_retbool(is_string(car(sc->args)));
3759      case OP_INTEGERP:     /* integer? */
3760           s_retbool(is_integer(car(sc->args)));
3761      case OP_REALP:     /* real? */
3762           s_retbool(is_number(car(sc->args))); /* All numbers are real */
3763      case OP_CHARP:     /* char? */
3764           s_retbool(is_character(car(sc->args)));
3765 #if USE_CHAR_CLASSIFIERS
3766      case OP_CHARAP:     /* char-alphabetic? */
3767           s_retbool(Cisalpha(ivalue(car(sc->args))));
3768      case OP_CHARNP:     /* char-numeric? */
3769           s_retbool(Cisdigit(ivalue(car(sc->args))));
3770      case OP_CHARWP:     /* char-whitespace? */
3771           s_retbool(Cisspace(ivalue(car(sc->args))));
3772      case OP_CHARUP:     /* char-upper-case? */
3773           s_retbool(Cisupper(ivalue(car(sc->args))));
3774      case OP_CHARLP:     /* char-lower-case? */
3775           s_retbool(Cislower(ivalue(car(sc->args))));
3776 #endif
3777      case OP_PORTP:     /* port? */
3778           s_retbool(is_port(car(sc->args)));
3779      case OP_INPORTP:     /* input-port? */
3780           s_retbool(is_inport(car(sc->args)));
3781      case OP_OUTPORTP:     /* output-port? */
3782           s_retbool(is_outport(car(sc->args)));
3783      case OP_PROCP:       /* procedure? */
3784           /*--
3785               * continuation should be procedure by the example
3786               * (call-with-current-continuation procedure?) ==> #t
3787                  * in R^3 report sec. 6.9
3788               */
3789           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
3790                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
3791      case OP_PAIRP:       /* pair? */
3792           s_retbool(is_pair(car(sc->args)));
3793      case OP_LISTP:       /* list? */
3794        s_retbool(list_length(sc,car(sc->args)) >= 0);
3795
3796      case OP_ENVP:        /* environment? */
3797           s_retbool(is_environment(car(sc->args)));
3798      case OP_VECTORP:     /* vector? */
3799           s_retbool(is_vector(car(sc->args)));
3800      case OP_EQ:         /* eq? */
3801           s_retbool(car(sc->args) == cadr(sc->args));
3802      case OP_EQV:        /* eqv? */
3803           s_retbool(eqv(car(sc->args), cadr(sc->args)));
3804      default:
3805           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3806           Error_0(sc,sc->strbuff);
3807      }
3808      return sc->T;
3809 }
3810
3811 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
3812      pointer x, y;
3813
3814      switch (op) {
3815      case OP_FORCE:      /* force */
3816           sc->code = car(sc->args);
3817           if (is_promise(sc->code)) {
3818                /* Should change type to closure here */
3819                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3820                sc->args = sc->NIL;
3821                s_goto(sc,OP_APPLY);
3822           } else {
3823                s_return(sc,sc->code);
3824           }
3825
3826      case OP_SAVE_FORCED:     /* Save forced value replacing promise */
3827           memcpy(sc->code,sc->value,sizeof(struct cell));
3828           s_return(sc,sc->value);
3829
3830      case OP_WRITE:      /* write */
3831      case OP_DISPLAY:    /* display */
3832      case OP_WRITE_CHAR: /* write-char */
3833           if(is_pair(cdr(sc->args))) {
3834                if(cadr(sc->args)!=sc->outport) {
3835                     x=cons(sc,sc->outport,sc->NIL);
3836                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3837                     sc->outport=cadr(sc->args);
3838                }
3839           }
3840           sc->args = car(sc->args);
3841           if(op==OP_WRITE) {
3842                sc->print_flag = 1;
3843           } else {
3844                sc->print_flag = 0;
3845           }
3846           s_goto(sc,OP_P0LIST);
3847
3848      case OP_NEWLINE:    /* newline */
3849           if(is_pair(sc->args)) {
3850                if(car(sc->args)!=sc->outport) {
3851                     x=cons(sc,sc->outport,sc->NIL);
3852                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3853                     sc->outport=car(sc->args);
3854                }
3855           }
3856           putstr(sc, "\n");
3857           s_return(sc,sc->T);
3858
3859      case OP_ERR0:  /* error */
3860           sc->retcode=-1;
3861           if (!is_string(car(sc->args))) {
3862                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
3863                setimmutable(car(sc->args));
3864           }
3865           putstr(sc, "Error: ");
3866           putstr(sc, strvalue(car(sc->args)));
3867           sc->args = cdr(sc->args);
3868           s_goto(sc,OP_ERR1);
3869
3870      case OP_ERR1:  /* error */
3871           putstr(sc, " ");
3872           if (sc->args != sc->NIL) {
3873                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
3874                sc->args = car(sc->args);
3875                sc->print_flag = 1;
3876                s_goto(sc,OP_P0LIST);
3877           } else {
3878                putstr(sc, "\n");
3879                if(sc->interactive_repl) {
3880                     s_goto(sc,OP_T0LVL);
3881                } else {
3882                     return sc->NIL;
3883                }
3884           }
3885
3886      case OP_REVERSE:   /* reverse */
3887           s_return(sc,reverse(sc, car(sc->args)));
3888
3889      case OP_LIST_STAR: /* list* */
3890           s_return(sc,list_star(sc,sc->args));
3891
3892      case OP_APPEND:    /* append */
3893           x = sc->NIL;
3894           y = sc->args;
3895           if (y == x) {
3896               s_return(sc, x);
3897           }
3898
3899           /* cdr() in the while condition is not a typo. If car() */
3900           /* is used (append '() 'a) will return the wrong result.*/
3901           while (cdr(y) != sc->NIL) {
3902               x = revappend(sc, x, car(y));
3903               y = cdr(y);
3904               if (x == sc->F) {
3905                   Error_0(sc, "non-list argument to append");
3906               }
3907           }
3908
3909           s_return(sc, reverse_in_place(sc, car(y), x));
3910
3911 #if USE_PLIST
3912      case OP_PUT:        /* put */
3913           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3914                Error_0(sc,"illegal use of put");
3915           }
3916           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3917                if (caar(x) == y) {
3918                     break;
3919                }
3920           }
3921           if (x != sc->NIL)
3922                cdar(x) = caddr(sc->args);
3923           else
3924                symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
3925                                 symprop(car(sc->args)));
3926           s_return(sc,sc->T);
3927
3928      case OP_GET:        /* get */
3929           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3930                Error_0(sc,"illegal use of get");
3931           }
3932           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3933                if (caar(x) == y) {
3934                     break;
3935                }
3936           }
3937           if (x != sc->NIL) {
3938                s_return(sc,cdar(x));
3939           } else {
3940                s_return(sc,sc->NIL);
3941           }
3942 #endif /* USE_PLIST */
3943      case OP_QUIT:       /* quit */
3944           if(is_pair(sc->args)) {
3945                sc->retcode=ivalue(car(sc->args));
3946           }
3947           return (sc->NIL);
3948
3949      case OP_GC:         /* gc */
3950           gc(sc, sc->NIL, sc->NIL);
3951           s_return(sc,sc->T);
3952
3953      case OP_GCVERB:          /* gc-verbose */
3954      {    int  was = sc->gc_verbose;
3955
3956           sc->gc_verbose = (car(sc->args) != sc->F);
3957           s_retbool(was);
3958      }
3959
3960      case OP_NEWSEGMENT: /* new-segment */
3961           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3962                Error_0(sc,"new-segment: argument must be a number");
3963           }
3964           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
3965           s_return(sc,sc->T);
3966
3967      case OP_OBLIST: /* oblist */
3968           s_return(sc, oblist_all_symbols(sc));
3969
3970      case OP_CURR_INPORT: /* current-input-port */
3971           s_return(sc,sc->inport);
3972
3973      case OP_CURR_OUTPORT: /* current-output-port */
3974           s_return(sc,sc->outport);
3975
3976      case OP_OPEN_INFILE: /* open-input-file */
3977      case OP_OPEN_OUTFILE: /* open-output-file */
3978      case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
3979           int prop=0;
3980           pointer p;
3981           switch(op) {
3982                case OP_OPEN_INFILE:     prop=port_input; break;
3983                case OP_OPEN_OUTFILE:    prop=port_output; break;
3984                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
3985                default: assert (! "reached");
3986           }
3987           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
3988           if(p==sc->NIL) {
3989                s_return(sc,sc->F);
3990           }
3991           s_return(sc,p);
3992           break;
3993      default: assert (! "reached");
3994      }
3995
3996 #if USE_STRING_PORTS
3997      case OP_OPEN_INSTRING: /* open-input-string */
3998      case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
3999           int prop=0;
4000           pointer p;
4001           switch(op) {
4002                case OP_OPEN_INSTRING:     prop=port_input; break;
4003                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
4004                default: assert (! "reached");
4005           }
4006           p=port_from_string(sc, strvalue(car(sc->args)),
4007                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
4008           if(p==sc->NIL) {
4009                s_return(sc,sc->F);
4010           }
4011           s_return(sc,p);
4012      }
4013      case OP_OPEN_OUTSTRING: /* open-output-string */ {
4014           pointer p;
4015           if(car(sc->args)==sc->NIL) {
4016                p=port_from_scratch(sc);
4017                if(p==sc->NIL) {
4018                     s_return(sc,sc->F);
4019                }
4020           } else {
4021                p=port_from_string(sc, strvalue(car(sc->args)),
4022                       strvalue(car(sc->args))+strlength(car(sc->args)),
4023                           port_output);
4024                if(p==sc->NIL) {
4025                     s_return(sc,sc->F);
4026                }
4027           }
4028           s_return(sc,p);
4029      }
4030      case OP_GET_OUTSTRING: /* get-output-string */ {
4031           port *p;
4032
4033           if ((p=car(sc->args)->_object._port)->kind&port_string) {
4034                off_t size;
4035                char *str;
4036
4037                size=p->rep.string.curr-p->rep.string.start+1;
4038                str=sc->malloc(size);
4039                if(str != NULL) {
4040                     pointer s;
4041
4042                     memcpy(str,p->rep.string.start,size-1);
4043                     str[size-1]='\0';
4044                     s=mk_string(sc,str);
4045                     sc->free(str);
4046                     s_return(sc,s);
4047                }
4048           }
4049           s_return(sc,sc->F);
4050      }
4051 #endif
4052
4053      case OP_CLOSE_INPORT: /* close-input-port */
4054           port_close(sc,car(sc->args),port_input);
4055           s_return(sc,sc->T);
4056
4057      case OP_CLOSE_OUTPORT: /* close-output-port */
4058           port_close(sc,car(sc->args),port_output);
4059           s_return(sc,sc->T);
4060
4061      case OP_INT_ENV: /* interaction-environment */
4062           s_return(sc,sc->global_env);
4063
4064      case OP_CURR_ENV: /* current-environment */
4065           s_return(sc,sc->envir);
4066
4067      }
4068      return sc->T;
4069 }
4070
4071 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
4072      pointer x;
4073
4074      if(sc->nesting!=0) {
4075           int n=sc->nesting;
4076           sc->nesting=0;
4077           sc->retcode=-1;
4078           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
4079      }
4080
4081      switch (op) {
4082      /* ========== reading part ========== */
4083      case OP_READ:
4084           if(!is_pair(sc->args)) {
4085                s_goto(sc,OP_READ_INTERNAL);
4086           }
4087           if(!is_inport(car(sc->args))) {
4088                Error_1(sc,"read: not an input port:",car(sc->args));
4089           }
4090           if(car(sc->args)==sc->inport) {
4091                s_goto(sc,OP_READ_INTERNAL);
4092           }
4093           x=sc->inport;
4094           sc->inport=car(sc->args);
4095           x=cons(sc,x,sc->NIL);
4096           s_save(sc,OP_SET_INPORT, x, sc->NIL);
4097           s_goto(sc,OP_READ_INTERNAL);
4098
4099      case OP_READ_CHAR: /* read-char */
4100      case OP_PEEK_CHAR: /* peek-char */ {
4101           int c;
4102           if(is_pair(sc->args)) {
4103                if(car(sc->args)!=sc->inport) {
4104                     x=sc->inport;
4105                     x=cons(sc,x,sc->NIL);
4106                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
4107                     sc->inport=car(sc->args);
4108                }
4109           }
4110           c=inchar(sc);
4111           if(c==EOF) {
4112                s_return(sc,sc->EOF_OBJ);
4113           }
4114           if(sc->op==OP_PEEK_CHAR) {
4115                backchar(sc,c);
4116           }
4117           s_return(sc,mk_character(sc,c));
4118      }
4119
4120      case OP_CHAR_READY: /* char-ready? */ {
4121           pointer p=sc->inport;
4122           int res;
4123           if(is_pair(sc->args)) {
4124                p=car(sc->args);
4125           }
4126           res=p->_object._port->kind&port_string;
4127           s_retbool(res);
4128      }
4129
4130      case OP_SET_INPORT: /* set-input-port */
4131           sc->inport=car(sc->args);
4132           s_return(sc,sc->value);
4133
4134      case OP_SET_OUTPORT: /* set-output-port */
4135           sc->outport=car(sc->args);
4136           s_return(sc,sc->value);
4137
4138      case OP_RDSEXPR:
4139           switch (sc->tok) {
4140           case TOK_EOF:
4141                s_return(sc,sc->EOF_OBJ);
4142           /* NOTREACHED */
4143 /*