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