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