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