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