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