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