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