tests/gpgscm/scheme.c

   1 /* T I N Y S C H E M E    1 . 4 1
   2  *   Dimitrios Souflis (dsouflis@acm.org)
   3  *   Based on MiniScheme (original credits follow)
   4  * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
   5  * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
   6  * (MINISCM) This version has been modified by R.C. Secrist.
   7  * (MINISCM)
   8  * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
   9  * (MINISCM)
  10  * (MINISCM) This is a revised and modified version by Akira KIDA.
  11  * (MINISCM)    current version is 0.85k4 (15 May 1994)
  12  *
  13  */
  14
  15 #define _SCHEME_SOURCE
  16 #include "scheme-private.h"
  17 #ifndef WIN32
  18 # include <unistd.h>
  19 #endif
  20 #ifdef WIN32
  21 #define snprintf _snprintf
  22 #endif
  23 #if USE_DL
  24 # include "dynload.h"
  25 #endif
  26 #if USE_MATH
  27 # include <math.h>
  28 #endif
  29
  30 #include <assert.h>
  31 #include <limits.h>
  32 #include <stdint.h>
  33 #include <float.h>
  34 #include <ctype.h>
  35
  36 #if USE_STRCASECMP
  37 #include <strings.h>
  38 # ifndef __APPLE__
  39 #  define stricmp strcasecmp
  40 # endif
  41 #endif
  42
  43 /* Used for documentation purposes, to signal functions in 'interface' */
  44 #define INTERFACE
  45
  46 #define TOK_EOF     (-1)
  47 #define TOK_LPAREN  0
  48 #define TOK_RPAREN  1
  49 #define TOK_DOT     2
  50 #define TOK_ATOM    3
  51 #define TOK_QUOTE   4
  52 #define TOK_COMMENT 5
  53 #define TOK_DQUOTE  6
  54 #define TOK_BQUOTE  7
  55 #define TOK_COMMA   8
  56 #define TOK_ATMARK  9
  57 #define TOK_SHARP   10
  58 #define TOK_SHARP_CONST 11
  59 #define TOK_VEC     12
  60
  61 #define BACKQUOTE '`'
  62 #define DELIMITERS  "()\";\f\t\v\n\r "
  63
  64 /*
  65  *  Basic memory allocation units
  66  */
  67
  68 #define banner "TinyScheme 1.41"
  69
  70 #include <string.h>
  71 #include <stddef.h>
  72 #include <stdlib.h>
  73
  74 #ifdef __APPLE__
  75 static int stricmp(const char *s1, const char *s2)
  76 {
  77   unsigned char c1, c2;
  78   do {
  79     c1 = tolower(*s1);
  80     c2 = tolower(*s2);
  81     if (c1 < c2)
  82       return -1;
  83     else if (c1 > c2)
  84       return 1;
  85     s1++, s2++;
  86   } while (c1 != 0);
  87   return 0;
  88 }
  89 #endif /* __APPLE__ */
  90
  91 #if USE_STRLWR
  92 static const char *strlwr(char *s) {
  93   const char *p=s;
  94   while(*s) {
  95     *s=tolower(*s);
  96     s++;
  97   }
  98   return p;
  99 }
 100 #endif
 101
 102 #ifndef prompt
 103 # define prompt "ts> "
 104 #endif
 105
 106 #ifndef InitFile
 107 # define InitFile "init.scm"
 108 #endif
 109
 110 #ifndef FIRST_CELLSEGS
 111 # define FIRST_CELLSEGS 3
 112 #endif
 113
 114 enum scheme_types {
 115   T_STRING=1,
 116   T_NUMBER=2,
 117   T_SYMBOL=3,
 118   T_PROC=4,
 119   T_PAIR=5,
 120   T_CLOSURE=6,
 121   T_CONTINUATION=7,
 122   T_FOREIGN=8,
 123   T_CHARACTER=9,
 124   T_PORT=10,
 125   T_VECTOR=11,
 126   T_MACRO=12,
 127   T_PROMISE=13,
 128   T_ENVIRONMENT=14,
 129   T_FOREIGN_OBJECT=15,
 130   T_BOOLEAN=16,
 131   T_NIL=17,
 132   T_EOF_OBJ=18,
 133   T_SINK=19,
 134   T_LAST_SYSTEM_TYPE=19
 135 };
 136
 137 static const char *
 138 type_to_string (enum scheme_types typ)
 139 {
 140      switch (typ)
 141      {
 142      case T_STRING: return "string";
 143      case T_NUMBER: return "number";
 144      case T_SYMBOL: return "symbol";
 145      case T_PROC: return "proc";
 146      case T_PAIR: return "pair";
 147      case T_CLOSURE: return "closure";
 148      case T_CONTINUATION: return "continuation";
 149      case T_FOREIGN: return "foreign";
 150      case T_CHARACTER: return "character";
 151      case T_PORT: return "port";
 152      case T_VECTOR: return "vector";
 153      case T_MACRO: return "macro";
 154      case T_PROMISE: return "promise";
 155      case T_ENVIRONMENT: return "environment";
 156      case T_FOREIGN_OBJECT: return "foreign object";
 157      case T_BOOLEAN: return "boolean";
 158      case T_NIL: return "nil";
 159      case T_EOF_OBJ: return "eof object";
 160      case T_SINK: return "sink";
 161      }
 162      assert (! "not reached");
 163 }
 164
 165 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
 166 #define ADJ 32
 167 #define TYPE_BITS 5
 168 #define T_MASKTYPE      31    /* 0000000000011111 */
 169 #define T_TAGGED      1024    /* 0000010000000000 */
 170 #define T_FINALIZE    2048    /* 0000100000000000 */
 171 #define T_SYNTAX      4096    /* 0001000000000000 */
 172 #define T_IMMUTABLE   8192    /* 0010000000000000 */
 173 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
 174 #define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
 175 #define MARK         32768    /* 1000000000000000 */
 176 #define UNMARK       32767    /* 0111111111111111 */
 177
 178
 179 static num num_add(num a, num b);
 180 static num num_mul(num a, num b);
 181 static num num_div(num a, num b);
 182 static num num_intdiv(num a, num b);
 183 static num num_sub(num a, num b);
 184 static num num_rem(num a, num b);
 185 static num num_mod(num a, num b);
 186 static int num_eq(num a, num b);
 187 static int num_gt(num a, num b);
 188 static int num_ge(num a, num b);
 189 static int num_lt(num a, num b);
 190 static int num_le(num a, num b);
 191
 192 #if USE_MATH
 193 static double round_per_R5RS(double x);
 194 #endif
 195 static int is_zero_double(double x);
 196 static INLINE int num_is_integer(pointer p) {
 197   return ((p)->_object._number.is_fixnum);
 198 }
 199
 200 static num num_zero;
 201 static num num_one;
 202
 203 /* macros for cell operations */
 204 #define typeflag(p)      ((p)->_flag)
 205 #define type(p)          (typeflag(p)&T_MASKTYPE)
 206
 207 INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
 208 #define strvalue(p)      ((p)->_object._string._svalue)
 209 #define strlength(p)        ((p)->_object._string._length)
 210
 211 INTERFACE static int is_list(scheme *sc, pointer p);
 212 INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
 213 INTERFACE static void fill_vector(pointer vec, pointer obj);
 214 INTERFACE static pointer vector_elem(pointer vec, int ielem);
 215 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
 216 INTERFACE INLINE int is_number(pointer p)    { return (type(p)==T_NUMBER); }
 217 INTERFACE INLINE int is_integer(pointer p) {
 218   if (!is_number(p))
 219       return 0;
 220   if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
 221       return 1;
 222   return 0;
 223 }
 224
 225 INTERFACE INLINE int is_real(pointer p) {
 226   return is_number(p) && (!(p)->_object._number.is_fixnum);
 227 }
 228
 229 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
 230 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
 231 INLINE num nvalue(pointer p)       { return ((p)->_object._number); }
 232 INTERFACE long ivalue(pointer p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
 233 INTERFACE double rvalue(pointer p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
 234 #define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
 235 #define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
 236 #define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
 237 #define set_num_real(p)      (p)->_object._number.is_fixnum=0;
 238 INTERFACE  long charvalue(pointer p)  { return ivalue_unchecked(p); }
 239
 240 INTERFACE INLINE int is_port(pointer p)     { return (type(p)==T_PORT); }
 241 INTERFACE INLINE int is_inport(pointer p)  { return is_port(p) && p->_object._port->kind & port_input; }
 242 INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
 243
 244 INTERFACE INLINE int is_pair(pointer p)     { return (type(p)==T_PAIR); }
 245 #define car(p)           ((p)->_object._cons._car)
 246 #define cdr(p)           ((p)->_object._cons._cdr)
 247 INTERFACE pointer pair_car(pointer p)   { return car(p); }
 248 INTERFACE pointer pair_cdr(pointer p)   { return cdr(p); }
 249 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
 250 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
 251
 252 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
 253 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
 254 #if USE_PLIST
 255 SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (is_symbol(p)); }
 256 #define symprop(p)       cdr(p)
 257 #endif
 258
 259 INTERFACE INLINE int is_syntax(pointer p)   { return (typeflag(p)&T_SYNTAX); }
 260 INTERFACE INLINE int is_proc(pointer p)     { return (type(p)==T_PROC); }
 261 INTERFACE INLINE int is_foreign(pointer p)  { return (type(p)==T_FOREIGN); }
 262 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
 263 #define procnum(p)       ivalue(p)
 264 static const char *procname(pointer x);
 265
 266 INTERFACE INLINE int is_closure(pointer p)  { return (type(p)==T_CLOSURE); }
 267 INTERFACE INLINE int is_macro(pointer p)    { return (type(p)==T_MACRO); }
 268 INTERFACE INLINE pointer closure_code(pointer p)   { return car(p); }
 269 INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
 270
 271 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
 272 #define cont_dump(p)     cdr(p)
 273
 274 INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
 275 INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
 276   return p->_object._foreign_object._vtable;
 277 }
 278 INTERFACE void *get_foreign_object_data(pointer p) {
 279   return p->_object._foreign_object._data;
 280 }
 281
 282 /* To do: promise should be forced ONCE only */
 283 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
 284
 285 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
 286 #define setenvironment(p)    typeflag(p) = T_ENVIRONMENT
 287
 288 #define is_atom(p)       (typeflag(p)&T_ATOM)
 289 #define setatom(p)       typeflag(p) |= T_ATOM
 290 #define clratom(p)       typeflag(p) &= CLRATOM
 291
 292 #define is_mark(p)       (typeflag(p)&MARK)
 293 #define setmark(p)       typeflag(p) |= MARK
 294 #define clrmark(p)       typeflag(p) &= UNMARK
 295
 296 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
 297 /*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
 298 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
 299
 300 #define caar(p)          car(car(p))
 301 #define cadr(p)          car(cdr(p))
 302 #define cdar(p)          cdr(car(p))
 303 #define cddr(p)          cdr(cdr(p))
 304 #define cadar(p)         car(cdr(car(p)))
 305 #define caddr(p)         car(cdr(cdr(p)))
 306 #define cdaar(p)         cdr(car(car(p)))
 307 #define cadaar(p)        car(cdr(car(car(p))))
 308 #define cadddr(p)        car(cdr(cdr(cdr(p))))
 309 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
 310
 311 #if USE_HISTORY
 312 static pointer history_flatten(scheme *sc);
 313 static void history_mark(scheme *sc);
 314 #else
 315 # define history_mark(SC)       (void) 0
 316 # define history_flatten(SC)    (SC)->NIL
 317 #endif
 318
 319 #if USE_CHAR_CLASSIFIERS
 320 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
 321 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
 322 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
 323 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
 324 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
 325 #endif
 326
 327 #if USE_ASCII_NAMES
 328 static const char *charnames[32]={
 329  "nul",
 330  "soh",
 331  "stx",
 332  "etx",
 333  "eot",
 334  "enq",
 335  "ack",
 336  "bel",
 337  "bs",
 338  "ht",
 339  "lf",
 340  "vt",
 341  "ff",
 342  "cr",
 343  "so",
 344  "si",
 345  "dle",
 346  "dc1",
 347  "dc2",
 348  "dc3",
 349  "dc4",
 350  "nak",
 351  "syn",
 352  "etb",
 353  "can",
 354  "em",
 355  "sub",
 356  "esc",
 357  "fs",
 358  "gs",
 359  "rs",
 360  "us"
 361 };
 362
 363 static int is_ascii_name(const char *name, int *pc) {
 364   int i;
 365   for(i=0; i<32; i++) {
 366      if(stricmp(name,charnames[i])==0) {
 367           *pc=i;
 368           return 1;
 369      }
 370   }
 371   if(stricmp(name,"del")==0) {
 372      *pc=127;
 373      return 1;
 374   }
 375   return 0;
 376 }
 377
 378 #endif
 379
 380 static int file_push(scheme *sc, pointer fname);
 381 static void file_pop(scheme *sc);
 382 static int file_interactive(scheme *sc);
 383 static INLINE int is_one_of(char *s, int c);
 384 static int alloc_cellseg(scheme *sc, int n);
 385 static long binary_decode(const char *s);
 386 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
 387 static pointer _get_cell(scheme *sc, pointer a, pointer b);
 388 static pointer reserve_cells(scheme *sc, int n);
 389 static pointer get_consecutive_cells(scheme *sc, int n);
 390 static pointer find_consecutive_cells(scheme *sc, int n);
 391 static void finalize_cell(scheme *sc, pointer a);
 392 static int count_consecutive_cells(pointer x, int needed);
 393 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
 394 static pointer mk_number(scheme *sc, num n);
 395 static char *store_string(scheme *sc, int len, const char *str, char fill);
 396 static pointer mk_vector(scheme *sc, int len);
 397 static pointer mk_atom(scheme *sc, char *q);
 398 static pointer mk_sharp_const(scheme *sc, char *name);
 399 static pointer mk_port(scheme *sc, port *p);
 400 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
 401 static pointer port_from_file(scheme *sc, FILE *, int prop);
 402 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
 403 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
 404 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
 405 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
 406 static void port_close(scheme *sc, pointer p, int flag);
 407 static void mark(pointer a);
 408 static void gc(scheme *sc, pointer a, pointer b);
 409 static int basic_inchar(port *pt);
 410 static int inchar(scheme *sc);
 411 static void backchar(scheme *sc, int c);
 412 static char   *readstr_upto(scheme *sc, char *delim);
 413 static pointer readstrexp(scheme *sc);
 414 static INLINE int skipspace(scheme *sc);
 415 static int token(scheme *sc);
 416 static void printslashstring(scheme *sc, char *s, int len);
 417 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
 418 static void printatom(scheme *sc, pointer l, int f);
 419 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
 420 static pointer mk_closure(scheme *sc, pointer c, pointer e);
 421 static pointer mk_continuation(scheme *sc, pointer d);
 422 static pointer reverse(scheme *sc, pointer term, pointer list);
 423 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
 424 static pointer revappend(scheme *sc, pointer a, pointer b);
 425 static void dump_stack_mark(scheme *);
 426 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
 427 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
 428 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
 429 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
 430 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
 431 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
 432 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
 433 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
 434 static void assign_syntax(scheme *sc, char *name);
 435 static int syntaxnum(pointer p);
 436 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
 437
 438 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
 439 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
 440
 441 static num num_add(num a, num b) {
 442  num ret;
 443  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 444  if(ret.is_fixnum) {
 445      ret.value.ivalue= a.value.ivalue+b.value.ivalue;
 446  } else {
 447      ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
 448  }
 449  return ret;
 450 }
 451
 452 static num num_mul(num a, num b) {
 453  num ret;
 454  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 455  if(ret.is_fixnum) {
 456      ret.value.ivalue= a.value.ivalue*b.value.ivalue;
 457  } else {
 458      ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
 459  }
 460  return ret;
 461 }
 462
 463 static num num_div(num a, num b) {
 464  num ret;
 465  ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
 466  if(ret.is_fixnum) {
 467      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 468  } else {
 469      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 470  }
 471  return ret;
 472 }
 473
 474 static num num_intdiv(num a, num b) {
 475  num ret;
 476  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 477  if(ret.is_fixnum) {
 478      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 479  } else {
 480      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 481  }
 482  return ret;
 483 }
 484
 485 static num num_sub(num a, num b) {
 486  num ret;
 487  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 488  if(ret.is_fixnum) {
 489      ret.value.ivalue= a.value.ivalue-b.value.ivalue;
 490  } else {
 491      ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
 492  }
 493  return ret;
 494 }
 495
 496 static num num_rem(num a, num b) {
 497  num ret;
 498  long e1, e2, res;
 499  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 500  e1=num_ivalue(a);
 501  e2=num_ivalue(b);
 502  res=e1%e2;
 503  /* remainder should have same sign as second operand */
 504  if (res > 0) {
 505      if (e1 < 0) {
 506         res -= labs(e2);
 507      }
 508  } else if (res < 0) {
 509      if (e1 > 0) {
 510          res += labs(e2);
 511      }
 512  }
 513  ret.value.ivalue=res;
 514  return ret;
 515 }
 516
 517 static num num_mod(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  /* modulo should have same sign as second operand */
 525  if (res * e2 < 0) {
 526     res += e2;
 527  }
 528  ret.value.ivalue=res;
 529  return ret;
 530 }
 531
 532 static int num_eq(num a, num b) {
 533  int ret;
 534  int is_fixnum=a.is_fixnum && b.is_fixnum;
 535  if(is_fixnum) {
 536      ret= a.value.ivalue==b.value.ivalue;
 537  } else {
 538      ret=num_rvalue(a)==num_rvalue(b);
 539  }
 540  return ret;
 541 }
 542
 543
 544 static int num_gt(num a, num b) {
 545  int ret;
 546  int is_fixnum=a.is_fixnum && b.is_fixnum;
 547  if(is_fixnum) {
 548      ret= a.value.ivalue>b.value.ivalue;
 549  } else {
 550      ret=num_rvalue(a)>num_rvalue(b);
 551  }
 552  return ret;
 553 }
 554
 555 static int num_ge(num a, num b) {
 556  return !num_lt(a,b);
 557 }
 558
 559 static int num_lt(num a, num b) {
 560  int ret;
 561  int is_fixnum=a.is_fixnum && b.is_fixnum;
 562  if(is_fixnum) {
 563      ret= a.value.ivalue<b.value.ivalue;
 564  } else {
 565      ret=num_rvalue(a)<num_rvalue(b);
 566  }
 567  return ret;
 568 }
 569
 570 static int num_le(num a, num b) {
 571  return !num_gt(a,b);
 572 }
 573
 574 #if USE_MATH
 575 /* Round to nearest. Round to even if midway */
 576 static double round_per_R5RS(double x) {
 577  double fl=floor(x);
 578  double ce=ceil(x);
 579  double dfl=x-fl;
 580  double dce=ce-x;
 581  if(dfl>dce) {
 582      return ce;
 583  } else if(dfl<dce) {
 584      return fl;
 585  } else {
 586      if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
 587           return fl;
 588      } else {
 589           return ce;
 590      }
 591  }
 592 }
 593 #endif
 594
 595 static int is_zero_double(double x) {
 596  return x<DBL_MIN && x>-DBL_MIN;
 597 }
 598
 599 static long binary_decode(const char *s) {
 600  long x=0;
 601
 602  while(*s!=0 && (*s=='1' || *s=='0')) {
 603      x<<=1;
 604      x+=*s-'0';
 605      s++;
 606  }
 607
 608  return x;
 609 }
 610
 611 \f
 612
 613 /* Tags are like property lists, but can be attached to arbitrary
 614  * values.  */
 615
 616 #if USE_TAGS
 617
 618 static pointer
 619 mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
 620 {
 621   pointer r, t;
 622
 623   assert(! is_vector(v));
 624
 625   r = get_consecutive_cells(sc, 2);
 626   if (r == sc->sink)
 627     return sc->sink;
 628
 629   memcpy(r, v, sizeof *v);
 630   typeflag(r) |= T_TAGGED;
 631
 632   t = r + 1;
 633   typeflag(t) = T_PAIR;
 634   car(t) = tag_car;
 635   cdr(t) = tag_cdr;
 636
 637   return r;
 638 }
 639
 640 static INLINE int
 641 has_tag(pointer v)
 642 {
 643   return !! (typeflag(v) & T_TAGGED);
 644 }
 645
 646 static INLINE pointer
 647 get_tag(scheme *sc, pointer v)
 648 {
 649   if (has_tag(v))
 650     return v + 1;
 651   return sc->NIL;
 652 }
 653
 654 #else
 655
 656 #define mk_tagged_value(SC, X, A, B)    (X)
 657 #define has_tag(V)                      0
 658 #define get_tag(SC, V)                  (SC)->NIL
 659
 660 #endif
 661
 662 \f
 663
 664 /* Allocate a new cell segment but do not make it available yet.  */
 665 static int
 666 _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
 667 {
 668   int adj = ADJ;
 669   void *cp;
 670
 671   if (adj < sizeof(struct cell))
 672     adj = sizeof(struct cell);
 673
 674   cp = sc->malloc(len * sizeof(struct cell) + adj);
 675   if (cp == NULL)
 676     return 1;
 677
 678   *alloc = cp;
 679
 680   /* adjust in TYPE_BITS-bit boundary */
 681   if (((uintptr_t) cp) % adj != 0)
 682     cp = (void *) (adj * ((uintptr_t) cp / adj + 1));
 683
 684   *cells = cp;
 685   return 0;
 686 }
 687
 688 /* allocate new cell segment */
 689 static int alloc_cellseg(scheme *sc, int n) {
 690      pointer newp;
 691      pointer last;
 692      pointer p;
 693      long i;
 694      int k;
 695
 696      for (k = 0; k < n; k++) {
 697          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
 698               return k;
 699          i = ++sc->last_cell_seg;
 700          if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) {
 701               sc->last_cell_seg--;
 702               return k;
 703          }
 704          /* insert new segment in address order */
 705          sc->cell_seg[i] = newp;
 706          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
 707              p = sc->cell_seg[i];
 708              sc->cell_seg[i] = sc->cell_seg[i - 1];
 709              sc->cell_seg[--i] = p;
 710          }
 711          sc->fcells += CELL_SEGSIZE;
 712          last = newp + CELL_SEGSIZE - 1;
 713          for (p = newp; p <= last; p++) {
 714               typeflag(p) = 0;
 715               cdr(p) = p + 1;
 716               car(p) = sc->NIL;
 717          }
 718          /* insert new cells in address order on free list */
 719          if (sc->free_cell == sc->NIL || p < sc->free_cell) {
 720               cdr(last) = sc->free_cell;
 721               sc->free_cell = newp;
 722          } else {
 723                p = sc->free_cell;
 724                while (cdr(p) != sc->NIL && newp > cdr(p))
 725                     p = cdr(p);
 726                cdr(last) = cdr(p);
 727                cdr(p) = newp;
 728          }
 729      }
 730      return n;
 731 }
 732
 733 \f
 734
 735 /* Controlling the garbage collector.
 736  *
 737  * Every time a cell is allocated, the interpreter may run out of free
 738  * cells and do a garbage collection.  This is problematic because it
 739  * might garbage collect objects that have been allocated, but are not
 740  * yet made available to the interpreter.
 741  *
 742  * Previously, we would plug such newly allocated cells into the list
 743  * of newly allocated objects rooted at car(sc->sink), but that
 744  * requires allocating yet another cell increasing pressure on the
 745  * memory management system.
 746  *
 747  * A faster alternative is to preallocate the cells needed for an
 748  * operation and make sure the garbage collection is not run until all
 749  * allocated objects are plugged in.  This can be done with gc_disable
 750  * and gc_enable.
 751  */
 752
 753 /* The garbage collector is enabled if the inhibit counter is
 754  * zero.  */
 755 #define GC_ENABLED      0
 756
 757 /* For now we provide a way to disable this optimization for
 758  * benchmarking and because it produces slightly smaller code.  */
 759 #ifndef USE_GC_LOCKING
 760 # define USE_GC_LOCKING 1
 761 #endif
 762
 763 /* To facilitate nested calls to gc_disable, functions that allocate
 764  * more than one cell may define a macro, e.g. foo_allocates.  This
 765  * macro can be used to compute the amount of preallocation at the
 766  * call site with the help of this macro.  */
 767 #define gc_reservations(fn) fn ## _allocates
 768
 769 #if USE_GC_LOCKING
 770
 771 /* Report a shortage in reserved cells, and terminate the program.  */
 772 static void
 773 gc_reservation_failure(struct scheme *sc)
 774 {
 775 #ifdef NDEBUG
 776   fprintf(stderr,
 777           "insufficient reservation\n")
 778 #else
 779   fprintf(stderr,
 780           "insufficient reservation in line %d\n",
 781           sc->reserved_lineno);
 782 #endif
 783   abort();
 784 }
 785
 786 /* Disable the garbage collection and reserve the given number of
 787  * cells.  gc_disable may be nested, but the enclosing reservation
 788  * must include the reservations of all nested calls.  Note: You must
 789  * re-enable the gc before calling Error_X.  */
 790 static void
 791 _gc_disable(struct scheme *sc, size_t reserve, int lineno)
 792 {
 793   if (sc->inhibit_gc == 0) {
 794     reserve_cells(sc, (reserve));
 795     sc->reserved_cells = (reserve);
 796 #ifndef NDEBUG
 797     (void) lineno;
 798 #else
 799     sc->reserved_lineno = lineno;
 800 #endif
 801   } else if (sc->reserved_cells < (reserve))
 802     gc_reservation_failure (sc);
 803   sc->inhibit_gc += 1;
 804 }
 805 #define gc_disable(sc, reserve)                 \
 806      _gc_disable (sc, reserve, __LINE__)
 807
 808 /* Enable the garbage collector.  */
 809 #define gc_enable(sc)                           \
 810      do {                                       \
 811           assert(sc->inhibit_gc);               \
 812           sc->inhibit_gc -= 1;                  \
 813      } while (0)
 814
 815 /* Test whether the garbage collector is enabled.  */
 816 #define gc_enabled(sc)                          \
 817      (sc->inhibit_gc == GC_ENABLED)
 818
 819 /* Consume a reserved cell.  */
 820 #define gc_consume(sc)                                                  \
 821      do {                                                               \
 822           assert(! gc_enabled (sc));                                    \
 823           if (sc->reserved_cells == 0)                                  \
 824                gc_reservation_failure (sc);                             \
 825           sc->reserved_cells -= 1;                                      \
 826      } while (0)
 827
 828 #else /* USE_GC_LOCKING */
 829
 830 #define gc_disable(sc, reserve) (void) 0
 831 #define gc_enable(sc)   (void) 0
 832 #define gc_enabled(sc)  1
 833 #define gc_consume(sc)  (void) 0
 834
 835 #endif /* USE_GC_LOCKING */
 836
 837 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
 838   if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
 839     pointer x = sc->free_cell;
 840     if (! gc_enabled (sc))
 841          gc_consume (sc);
 842     sc->free_cell = cdr(x);
 843     --sc->fcells;
 844     return (x);
 845   }
 846   assert (gc_enabled (sc));
 847   return _get_cell (sc, a, b);
 848 }
 849
 850
 851 /* get new cell.  parameter a, b is marked by gc. */
 852 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
 853   pointer x;
 854
 855   if(sc->no_memory) {
 856     return sc->sink;
 857   }
 858
 859   assert (gc_enabled (sc));
 860   if (sc->free_cell == sc->NIL) {
 861     const int min_to_be_recovered = sc->last_cell_seg*8;
 862     gc(sc,a, b);
 863     if (sc->fcells < min_to_be_recovered
 864         || sc->free_cell == sc->NIL) {
 865       /* if only a few recovered, get more to avoid fruitless gc's */
 866       if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
 867         sc->no_memory=1;
 868         return sc->sink;
 869       }
 870     }
 871   }
 872   x = sc->free_cell;
 873   sc->free_cell = cdr(x);
 874   --sc->fcells;
 875   return (x);
 876 }
 877
 878 /* make sure that there is a given number of cells free */
 879 static pointer reserve_cells(scheme *sc, int n) {
 880     if(sc->no_memory) {
 881         return sc->NIL;
 882     }
 883
 884     /* Are there enough cells available? */
 885     if (sc->fcells < n) {
 886         /* If not, try gc'ing some */
 887         gc(sc, sc->NIL, sc->NIL);
 888         if (sc->fcells < n) {
 889             /* If there still aren't, try getting more heap */
 890             if (!alloc_cellseg(sc,1)) {
 891                 sc->no_memory=1;
 892                 return sc->NIL;
 893             }
 894         }
 895         if (sc->fcells < n) {
 896             /* If all fail, report failure */
 897             sc->no_memory=1;
 898             return sc->NIL;
 899         }
 900     }
 901     return (sc->T);
 902 }
 903
 904 static pointer get_consecutive_cells(scheme *sc, int n) {
 905   pointer x;
 906
 907   if(sc->no_memory) { return sc->sink; }
 908
 909   /* Are there any cells available? */
 910   x=find_consecutive_cells(sc,n);
 911   if (x != sc->NIL) { return x; }
 912
 913   /* If not, try gc'ing some */
 914   gc(sc, sc->NIL, sc->NIL);
 915   x=find_consecutive_cells(sc,n);
 916   if (x != sc->NIL) { return x; }
 917
 918   /* If there still aren't, try getting more heap */
 919   if (!alloc_cellseg(sc,1))
 920     {
 921       sc->no_memory=1;
 922       return sc->sink;
 923     }
 924
 925   x=find_consecutive_cells(sc,n);
 926   if (x != sc->NIL) { return x; }
 927
 928   /* If all fail, report failure */
 929   sc->no_memory=1;
 930   return sc->sink;
 931 }
 932
 933 static int count_consecutive_cells(pointer x, int needed) {
 934  int n=1;
 935  while(cdr(x)==x+1) {
 936      x=cdr(x);
 937      n++;
 938      if(n>needed) return n;
 939  }
 940  return n;
 941 }
 942
 943 static pointer find_consecutive_cells(scheme *sc, int n) {
 944   pointer *pp;
 945   int cnt;
 946
 947   pp=&sc->free_cell;
 948   while(*pp!=sc->NIL) {
 949     cnt=count_consecutive_cells(*pp,n);
 950     if(cnt>=n) {
 951       pointer x=*pp;
 952       *pp=cdr(*pp+n-1);
 953       sc->fcells -= n;
 954       return x;
 955     }
 956     pp=&cdr(*pp+cnt-1);
 957   }
 958   return sc->NIL;
 959 }
 960
 961 /* Free a cell.  This is dangerous.  Only free cells that are not
 962  * referenced.  */
 963 static INLINE void
 964 free_cell(scheme *sc, pointer a)
 965 {
 966   cdr(a) = sc->free_cell;
 967   sc->free_cell = a;
 968   sc->fcells += 1;
 969 }
 970
 971 /* Free a cell and retrieve its content.  This is dangerous.  Only
 972  * free cells that are not referenced.  */
 973 static INLINE void
 974 free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
 975 {
 976   *r_car = car(a);
 977   *r_cdr = cdr(a);
 978   free_cell(sc, a);
 979 }
 980
 981 /* To retain recent allocs before interpreter knows about them -
 982    Tehom */
 983
 984 static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
 985 {
 986   pointer holder = get_cell_x(sc, recent, extra);
 987   typeflag(holder) = T_PAIR | T_IMMUTABLE;
 988   car(holder) = recent;
 989   cdr(holder) = car(sc->sink);
 990   car(sc->sink) = holder;
 991 }
 992
 993 static INLINE void ok_to_freely_gc(scheme *sc)
 994 {
 995   pointer a = car(sc->sink), next;
 996   car(sc->sink) = sc->NIL;
 997   while (a != sc->NIL)
 998     {
 999       next = cdr(a);
1000       free_cell(sc, a);
1001       a = next;
1002     }
1003 }
1004
1005 static pointer get_cell(scheme *sc, pointer a, pointer b)
1006 {
1007   pointer cell   = get_cell_x(sc, a, b);
1008   /* For right now, include "a" and "b" in "cell" so that gc doesn't
1009      think they are garbage. */
1010   /* Tentatively record it as a pair so gc understands it. */
1011   typeflag(cell) = T_PAIR;
1012   car(cell) = a;
1013   cdr(cell) = b;
1014   if (gc_enabled (sc))
1015     push_recent_alloc(sc, cell, sc->NIL);
1016   return cell;
1017 }
1018
1019 static pointer get_vector_object(scheme *sc, int len, pointer init)
1020 {
1021   pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
1022   if(sc->no_memory) { return sc->sink; }
1023   /* Record it as a vector so that gc understands it. */
1024   typeflag(cells) = (T_VECTOR | T_ATOM);
1025   ivalue_unchecked(cells)=len;
1026   set_num_integer(cells);
1027   fill_vector(cells,init);
1028   if (gc_enabled (sc))
1029     push_recent_alloc(sc, cells, sc->NIL);
1030   return cells;
1031 }
1032
1033 #if defined TSGRIND
1034 static void check_cell_alloced(pointer p, int expect_alloced)
1035 {
1036   /* Can't use putstr(sc,str) because callers have no access to
1037      sc.  */
1038   if(typeflag(p) & !expect_alloced)
1039     {
1040       fprintf(stderr,"Cell is already allocated!\n");
1041     }
1042   if(!(typeflag(p)) & expect_alloced)
1043     {
1044       fprintf(stderr,"Cell is not allocated!\n");
1045     }
1046
1047 }
1048 static void check_range_alloced(pointer p, int n, int expect_alloced)
1049 {
1050   int i;
1051   for(i = 0;i<n;i++)
1052     { (void)check_cell_alloced(p+i,expect_alloced); }
1053 }
1054
1055 #endif
1056
1057 /* Medium level cell allocation */
1058
1059 /* get new cons cell */
1060 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
1061   pointer x = get_cell(sc,a, b);
1062
1063   typeflag(x) = T_PAIR;
1064   if(immutable) {
1065     setimmutable(x);
1066   }
1067   car(x) = a;
1068   cdr(x) = b;
1069   return (x);
1070 }
1071
1072 /* ========== oblist implementation  ========== */
1073
1074 #ifndef USE_OBJECT_LIST
1075
1076 static int hash_fn(const char *key, int table_size);
1077
1078 static pointer oblist_initial_value(scheme *sc)
1079 {
1080   return mk_vector(sc, 461); /* probably should be bigger */
1081 }
1082
1083 /* returns the new symbol */
1084 static pointer oblist_add_by_name(scheme *sc, const char *name)
1085 {
1086 #define oblist_add_by_name_allocates    3
1087   pointer x;
1088   int location;
1089
1090   gc_disable(sc, gc_reservations (oblist_add_by_name));
1091   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
1092   typeflag(x) = T_SYMBOL;
1093   setimmutable(car(x));
1094
1095   location = hash_fn(name, ivalue_unchecked(sc->oblist));
1096   set_vector_elem(sc->oblist, location,
1097                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
1098   gc_enable(sc);
1099   return x;
1100 }
1101
1102 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
1103 {
1104   int location;
1105   pointer x;
1106   char *s;
1107
1108   location = hash_fn(name, ivalue_unchecked(sc->oblist));
1109   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
1110     s = symname(car(x));
1111     /* case-insensitive, per R5RS section 2. */
1112     if(stricmp(name, s) == 0) {
1113       return car(x);
1114     }
1115   }
1116   return sc->NIL;
1117 }
1118
1119 static pointer oblist_all_symbols(scheme *sc)
1120 {
1121   int i;
1122   pointer x;
1123   pointer ob_list = sc->NIL;
1124
1125   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
1126     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
1127       ob_list = cons(sc, x, ob_list);
1128     }
1129   }
1130   return ob_list;
1131 }
1132
1133 #else
1134
1135 static pointer oblist_initial_value(scheme *sc)
1136 {
1137   return sc->NIL;
1138 }
1139
1140 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
1141 {
1142      pointer x;
1143      char    *s;
1144
1145      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
1146         s = symname(car(x));
1147         /* case-insensitive, per R5RS section 2. */
1148         if(stricmp(name, s) == 0) {
1149           return car(x);
1150         }
1151      }
1152      return sc->NIL;
1153 }
1154
1155 /* returns the new symbol */
1156 static pointer oblist_add_by_name(scheme *sc, const char *name)
1157 {
1158   pointer x;
1159
1160   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
1161   typeflag(x) = T_SYMBOL;
1162   setimmutable(car(x));
1163   sc->oblist = immutable_cons(sc, x, sc->oblist);
1164   return x;
1165 }
1166 static pointer oblist_all_symbols(scheme *sc)
1167 {
1168   return sc->oblist;
1169 }
1170
1171 #endif
1172
1173 static pointer mk_port(scheme *sc, port *p) {
1174   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1175
1176   typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
1177   x->_object._port=p;
1178   return (x);
1179 }
1180
1181 pointer mk_foreign_func(scheme *sc, foreign_func f) {
1182   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1183
1184   typeflag(x) = (T_FOREIGN | T_ATOM);
1185   x->_object._ff=f;
1186   return (x);
1187 }
1188
1189 pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
1190   pointer x = get_cell(sc, sc->NIL, sc->NIL);
1191
1192   typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
1193   x->_object._foreign_object._vtable=vtable;
1194   x->_object._foreign_object._data = data;
1195   return (x);
1196 }
1197
1198 INTERFACE pointer mk_character(scheme *sc, int c) {
1199   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1200
1201   typeflag(x) = (T_CHARACTER | T_ATOM);
1202   ivalue_unchecked(x)= c;
1203   set_num_integer(x);
1204   return (x);
1205 }
1206
1207 \f
1208
1209 #if USE_SMALL_INTEGERS
1210
1211 /* s_save assumes that all opcodes can be expressed as a small
1212  * integer.  */
1213 #define MAX_SMALL_INTEGER       OP_MAXDEFINED
1214
1215 static int
1216 initialize_small_integers(scheme *sc)
1217 {
1218   int i;
1219   if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc,
1220                      &sc->integer_cells))
1221     return 1;
1222
1223   for (i = 0; i < MAX_SMALL_INTEGER; i++) {
1224     pointer x = &sc->integer_cells[i];
1225     typeflag(x) = T_NUMBER | T_ATOM | MARK;
1226     ivalue_unchecked(x) = i;
1227     set_num_integer(x);
1228   }
1229
1230   return 0;
1231 }
1232
1233 static INLINE pointer
1234 mk_small_integer(scheme *sc, long n)
1235 {
1236 #define mk_small_integer_allocates      0
1237   assert(0 <= n && n < MAX_SMALL_INTEGER);
1238   return &sc->integer_cells[n];
1239 }
1240 #else
1241
1242 #define mk_small_integer_allocates      1
1243 #define mk_small_integer        mk_integer
1244
1245 #endif
1246
1247 /* get number atom (integer) */
1248 INTERFACE pointer mk_integer(scheme *sc, long n) {
1249   pointer x;
1250
1251 #if USE_SMALL_INTEGERS
1252   if (0 <= n && n < MAX_SMALL_INTEGER)
1253     return mk_small_integer(sc, n);
1254 #endif
1255
1256   x = get_cell(sc,sc->NIL, sc->NIL);
1257   typeflag(x) = (T_NUMBER | T_ATOM);
1258   ivalue_unchecked(x)= n;
1259   set_num_integer(x);
1260   return (x);
1261 }
1262
1263 \f
1264
1265 INTERFACE pointer mk_real(scheme *sc, double n) {
1266   pointer x = get_cell(sc,sc->NIL, sc->NIL);
1267
1268   typeflag(x) = (T_NUMBER | T_ATOM);
1269   rvalue_unchecked(x)= n;
1270   set_num_real(x);
1271   return (x);
1272 }
1273
1274 static pointer mk_number(scheme *sc, num n) {
1275  if(n.is_fixnum) {
1276      return mk_integer(sc,n.value.ivalue);
1277  } else {
1278      return mk_real(sc,n.value.rvalue);
1279  }
1280 }
1281
1282 /* allocate name to string area */
1283 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
1284      char *q;
1285
1286      q=(char*)sc->malloc(len_str+1);
1287      if(q==0) {
1288           sc->no_memory=1;
1289           return sc->strbuff;
1290      }
1291      if(str!=0) {
1292           memcpy (q, str, len_str);
1293           q[len_str]=0;
1294      } else {
1295           memset(q, fill, len_str);
1296           q[len_str]=0;
1297      }
1298      return (q);
1299 }
1300
1301 /* get new string */
1302 INTERFACE pointer mk_string(scheme *sc, const char *str) {
1303      return mk_counted_string(sc,str,strlen(str));
1304 }
1305
1306 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
1307      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1308      typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1309      strvalue(x) = store_string(sc,len,str,0);
1310      strlength(x) = len;
1311      return (x);
1312 }
1313
1314 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
1315      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1316      typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1317      strvalue(x) = store_string(sc,len,0,fill);
1318      strlength(x) = len;
1319      return (x);
1320 }
1321
1322 INTERFACE static pointer mk_vector(scheme *sc, int len)
1323 { return get_vector_object(sc,len,sc->NIL); }
1324
1325 INTERFACE static void fill_vector(pointer vec, pointer obj) {
1326      int i;
1327      int n = ivalue(vec)/2+ivalue(vec)%2;
1328      for(i=0; i < n; i++) {
1329           typeflag(vec+1+i) = T_PAIR;
1330           setimmutable(vec+1+i);
1331           car(vec+1+i)=obj;
1332           cdr(vec+1+i)=obj;
1333      }
1334 }
1335
1336 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1337      int n=ielem/2;
1338      if(ielem%2==0) {
1339           return car(vec+1+n);
1340      } else {
1341           return cdr(vec+1+n);
1342      }
1343 }
1344
1345 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1346      int n=ielem/2;
1347      if(ielem%2==0) {
1348           return car(vec+1+n)=a;
1349      } else {
1350           return cdr(vec+1+n)=a;
1351      }
1352 }
1353
1354 /* get new symbol */
1355 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1356 #define mk_symbol_allocates     oblist_add_by_name_allocates
1357      pointer x;
1358
1359      /* first check oblist */
1360      x = oblist_find_by_name(sc, name);
1361      if (x != sc->NIL) {
1362           return (x);
1363      } else {
1364           x = oblist_add_by_name(sc, name);
1365           return (x);
1366      }
1367 }
1368
1369 INTERFACE pointer gensym(scheme *sc) {
1370      pointer x;
1371      char name[40];
1372
1373      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1374           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1375
1376           /* first check oblist */
1377           x = oblist_find_by_name(sc, name);
1378
1379           if (x != sc->NIL) {
1380                continue;
1381           } else {
1382                x = oblist_add_by_name(sc, name);
1383                return (x);
1384           }
1385      }
1386
1387      return sc->NIL;
1388 }
1389
1390 /* double the size of the string buffer */
1391 static int expand_strbuff(scheme *sc) {
1392   size_t new_size = sc->strbuff_size * 2;
1393   char *new_buffer = sc->malloc(new_size);
1394   if (new_buffer == 0) {
1395     sc->no_memory = 1;
1396     return 1;
1397   }
1398   memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
1399   sc->free(sc->strbuff);
1400   sc->strbuff = new_buffer;
1401   sc->strbuff_size = new_size;
1402   return 0;
1403 }
1404
1405 /* make symbol or number atom from string */
1406 static pointer mk_atom(scheme *sc, char *q) {
1407      char    c, *p;
1408      int has_dec_point=0;
1409      int has_fp_exp = 0;
1410
1411 #if USE_COLON_HOOK
1412      char *next;
1413      next = p = q;
1414      while ((next = strstr(next, "::")) != 0) {
1415           /* Keep looking for the last occurrence.  */
1416           p = next;
1417           next = next + 2;
1418      }
1419
1420      if (p != q) {
1421           *p=0;
1422           return cons(sc, sc->COLON_HOOK,
1423                           cons(sc,
1424                               cons(sc,
1425                                    sc->QUOTE,
1426                                    cons(sc, mk_symbol(sc, strlwr(p + 2)),
1427                                         sc->NIL)),
1428                               cons(sc, mk_atom(sc, q), sc->NIL)));
1429      }
1430 #endif
1431
1432      p = q;
1433      c = *p++;
1434      if ((c == '+') || (c == '-')) {
1435        c = *p++;
1436        if (c == '.') {
1437          has_dec_point=1;
1438          c = *p++;
1439        }
1440        if (!isdigit(c)) {
1441          return (mk_symbol(sc, strlwr(q)));
1442        }
1443      } else if (c == '.') {
1444        has_dec_point=1;
1445        c = *p++;
1446        if (!isdigit(c)) {
1447          return (mk_symbol(sc, strlwr(q)));
1448        }
1449      } else if (!isdigit(c)) {
1450        return (mk_symbol(sc, strlwr(q)));
1451      }
1452
1453      for ( ; (c = *p) != 0; ++p) {
1454           if (!isdigit(c)) {
1455                if(c=='.') {
1456                     if(!has_dec_point) {
1457                          has_dec_point=1;
1458                          continue;
1459                     }
1460                }
1461                else if ((c == 'e') || (c == 'E')) {
1462                        if(!has_fp_exp) {
1463                           has_dec_point = 1; /* decimal point illegal
1464                                                 from now on */
1465                           p++;
1466                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1467                              continue;
1468                           }
1469                        }
1470                }
1471                return (mk_symbol(sc, strlwr(q)));
1472           }
1473      }
1474      if(has_dec_point) {
1475           return mk_real(sc,atof(q));
1476      }
1477      return (mk_integer(sc, atol(q)));
1478 }
1479
1480 /* make constant */
1481 static pointer mk_sharp_const(scheme *sc, char *name) {
1482      long    x;
1483      char    tmp[STRBUFFSIZE];
1484
1485      if (!strcmp(name, "t"))
1486           return (sc->T);
1487      else if (!strcmp(name, "f"))
1488           return (sc->F);
1489      else if (*name == 'o') {/* #o (octal) */
1490           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1491           sscanf(tmp, "%lo", (long unsigned *)&x);
1492           return (mk_integer(sc, x));
1493      } else if (*name == 'd') {    /* #d (decimal) */
1494           sscanf(name+1, "%ld", (long int *)&x);
1495           return (mk_integer(sc, x));
1496      } else if (*name == 'x') {    /* #x (hex) */
1497           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
1498           sscanf(tmp, "%lx", (long unsigned *)&x);
1499           return (mk_integer(sc, x));
1500      } else if (*name == 'b') {    /* #b (binary) */
1501           x = binary_decode(name+1);
1502           return (mk_integer(sc, x));
1503      } else if (*name == '\\') { /* #\w (character) */
1504           int c=0;
1505           if(stricmp(name+1,"space")==0) {
1506                c=' ';
1507           } else if(stricmp(name+1,"newline")==0) {
1508                c='\n';
1509           } else if(stricmp(name+1,"return")==0) {
1510                c='\r';
1511           } else if(stricmp(name+1,"tab")==0) {
1512                c='\t';
1513      } else if(name[1]=='x' && name[2]!=0) {
1514           int c1=0;
1515           if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
1516                c=c1;
1517           } else {
1518                return sc->NIL;
1519      }
1520 #if USE_ASCII_NAMES
1521           } else if(is_ascii_name(name+1,&c)) {
1522                /* nothing */
1523 #endif
1524           } else if(name[2]==0) {
1525                c=name[1];
1526           } else {
1527                return sc->NIL;
1528           }
1529           return mk_character(sc,c);
1530      } else
1531           return (sc->NIL);
1532 }
1533
1534 /* ========== garbage collector ========== */
1535
1536 /*--
1537  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1538  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1539  *  for marking.
1540  */
1541 static void mark(pointer a) {
1542      pointer t, q, p;
1543
1544      t = (pointer) 0;
1545      p = a;
1546 E2:  setmark(p);
1547      if(is_vector(p)) {
1548           int i;
1549           int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1550           for(i=0; i < n; i++) {
1551                /* Vector cells will be treated like ordinary cells */
1552                mark(p+1+i);
1553           }
1554      }
1555 #if SHOW_ERROR_LINE
1556      else if (is_port(p)) {
1557           port *pt = p->_object._port;
1558           if (pt->kind & port_file) {
1559                mark(pt->rep.stdio.curr_line);
1560                mark(pt->rep.stdio.filename);
1561           }
1562      }
1563 #endif
1564      /* Mark tag if p has one.  */
1565      if (has_tag(p))
1566        mark(p + 1);
1567      if (is_atom(p))
1568           goto E6;
1569      /* E4: down car */
1570      q = car(p);
1571      if (q && !is_mark(q)) {
1572           setatom(p);  /* a note that we have moved car */
1573           car(p) = t;
1574           t = p;
1575           p = q;
1576           goto E2;
1577      }
1578 E5:  q = cdr(p); /* down cdr */
1579      if (q && !is_mark(q)) {
1580           cdr(p) = t;
1581           t = p;
1582           p = q;
1583           goto E2;
1584      }
1585 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1586      if (!t)
1587           return;
1588      q = t;
1589      if (is_atom(q)) {
1590           clratom(q);
1591           t = car(q);
1592           car(q) = p;
1593           p = q;
1594           goto E5;
1595      } else {
1596           t = cdr(q);
1597           cdr(q) = p;
1598           p = q;
1599           goto E6;
1600      }
1601 }
1602
1603 /* garbage collection. parameter a, b is marked. */
1604 static void gc(scheme *sc, pointer a, pointer b) {
1605   pointer p;
1606   int i;
1607
1608   assert (gc_enabled (sc));
1609
1610   if(sc->gc_verbose) {
1611     putstr(sc, "gc...");
1612   }
1613
1614   /* mark system globals */
1615   mark(sc->oblist);
1616   mark(sc->global_env);
1617
1618   /* mark current registers */
1619   mark(sc->args);
1620   mark(sc->envir);
1621   mark(sc->code);
1622   history_mark(sc);
1623   dump_stack_mark(sc);
1624   mark(sc->value);
1625   mark(sc->inport);
1626   mark(sc->save_inport);
1627   mark(sc->outport);
1628   mark(sc->loadport);
1629   for (i = 0; i <= sc->file_i; i++) {
1630     if (! (sc->load_stack[i].kind & port_file))
1631       continue;
1632
1633     mark(sc->load_stack[i].rep.stdio.filename);
1634     mark(sc->load_stack[i].rep.stdio.curr_line);
1635   }
1636
1637   /* Mark recent objects the interpreter doesn't know about yet. */
1638   mark(car(sc->sink));
1639   /* Mark any older stuff above nested C calls */
1640   mark(sc->c_nest);
1641
1642   /* mark variables a, b */
1643   mark(a);
1644   mark(b);
1645
1646   /* garbage collect */
1647   clrmark(sc->NIL);
1648   sc->fcells = 0;
1649   sc->free_cell = sc->NIL;
1650   /* free-list is kept sorted by address so as to maintain consecutive
1651      ranges, if possible, for use with vectors. Here we scan the cells
1652      (which are also kept sorted by address) downwards to build the
1653      free-list in sorted order.
1654   */
1655   for (i = sc->last_cell_seg; i >= 0; i--) {
1656     p = sc->cell_seg[i] + CELL_SEGSIZE;
1657     while (--p >= sc->cell_seg[i]) {
1658       if (is_mark(p)) {
1659     clrmark(p);
1660       } else {
1661     /* reclaim cell */
1662         if (typeflag(p) & T_FINALIZE) {
1663           finalize_cell(sc, p);
1664         }
1665         ++sc->fcells;
1666         typeflag(p) = 0;
1667         car(p) = sc->NIL;
1668         cdr(p) = sc->free_cell;
1669         sc->free_cell = p;
1670       }
1671     }
1672   }
1673
1674   if (sc->gc_verbose) {
1675     char msg[80];
1676     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1677     putstr(sc,msg);
1678   }
1679 }
1680
1681 static void finalize_cell(scheme *sc, pointer a) {
1682   if(is_string(a)) {
1683     sc->free(strvalue(a));
1684   } else if(is_port(a)) {
1685     if(a->_object._port->kind&port_file
1686        && a->_object._port->rep.stdio.closeit) {
1687       port_close(sc,a,port_input|port_output);
1688     } else if (a->_object._port->kind & port_srfi6) {
1689       sc->free(a->_object._port->rep.string.start);
1690     }
1691     sc->free(a->_object._port);
1692   } else if(is_foreign_object(a)) {
1693     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1694   }
1695 }
1696
1697 #if SHOW_ERROR_LINE
1698 static void
1699 port_clear_location (scheme *sc, port *p)
1700 {
1701   assert(p->kind & port_file);
1702   p->rep.stdio.curr_line = sc->NIL;
1703   p->rep.stdio.filename = sc->NIL;
1704 }
1705
1706 static void
1707 port_reset_current_line (scheme *sc, port *p)
1708 {
1709   assert(p->kind & port_file);
1710   p->rep.stdio.curr_line = mk_integer(sc, 0);
1711 }
1712
1713 static void
1714 port_increment_current_line (scheme *sc, port *p, long delta)
1715 {
1716   assert(p->kind & port_file);
1717   p->rep.stdio.curr_line =
1718     mk_integer(sc, ivalue_unchecked(p->rep.stdio.curr_line) + delta);
1719 }
1720 #endif
1721
1722 /* ========== Routines for Reading ========== */
1723
1724 static int file_push(scheme *sc, pointer fname) {
1725   FILE *fin = NULL;
1726
1727   if (sc->file_i == MAXFIL-1)
1728      return 0;
1729   fin = fopen(string_value(fname), "r");
1730   if(fin!=0) {
1731     sc->file_i++;
1732     sc->load_stack[sc->file_i].kind=port_file|port_input;
1733     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1734     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1735     sc->nesting_stack[sc->file_i]=0;
1736     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1737
1738 #if SHOW_ERROR_LINE
1739     port_reset_current_line(sc, &sc->load_stack[sc->file_i]);
1740     sc->load_stack[sc->file_i].rep.stdio.filename = fname;
1741 #endif
1742   }
1743   return fin!=0;
1744 }
1745
1746 static void file_pop(scheme *sc) {
1747  if(sc->file_i != 0) {
1748    sc->nesting=sc->nesting_stack[sc->file_i];
1749    port_close(sc,sc->loadport,port_input);
1750 #if SHOW_ERROR_LINE
1751    if (sc->load_stack[sc->file_i].kind & port_file)
1752      port_clear_location(sc, &sc->load_stack[sc->file_i]);
1753 #endif
1754    sc->file_i--;
1755    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1756  }
1757 }
1758
1759 static int file_interactive(scheme *sc) {
1760  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1761      && sc->inport->_object._port->kind&port_file;
1762 }
1763
1764 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1765   FILE *f;
1766   char *rw;
1767   port *pt;
1768   if(prop==(port_input|port_output)) {
1769     rw="a+";
1770   } else if(prop==port_output) {
1771     rw="w";
1772   } else {
1773     rw="r";
1774   }
1775   f=fopen(fn,rw);
1776   if(f==0) {
1777     return 0;
1778   }
1779   pt=port_rep_from_file(sc,f,prop);
1780   pt->rep.stdio.closeit=1;
1781
1782 #if SHOW_ERROR_LINE
1783   if (fn)
1784     pt->rep.stdio.filename = mk_string(sc, fn);
1785   else
1786     pt->rep.stdio.filename = mk_string(sc, "<unknown>");
1787
1788   port_reset_current_line(sc, pt);
1789 #endif
1790   return pt;
1791 }
1792
1793 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1794   port *pt;
1795   pt=port_rep_from_filename(sc,fn,prop);
1796   if(pt==0) {
1797     return sc->NIL;
1798   }
1799   return mk_port(sc,pt);
1800 }
1801
1802 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1803 {
1804     port *pt;
1805
1806     pt = (port *)sc->malloc(sizeof *pt);
1807     if (pt == NULL) {
1808         return NULL;
1809     }
1810     pt->kind = port_file | prop;
1811     pt->rep.stdio.file = f;
1812     pt->rep.stdio.closeit = 0;
1813 #if SHOW_ERROR_LINE
1814     pt->rep.stdio.filename = mk_string(sc, "<unknown>");
1815     port_reset_current_line(sc, pt);
1816 #endif
1817     return pt;
1818 }
1819
1820 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1821   port *pt;
1822   pt=port_rep_from_file(sc,f,prop);
1823   if(pt==0) {
1824     return sc->NIL;
1825   }
1826   return mk_port(sc,pt);
1827 }
1828
1829 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1830   port *pt;
1831   pt=(port*)sc->malloc(sizeof(port));
1832   if(pt==0) {
1833     return 0;
1834   }
1835   pt->kind=port_string|prop;
1836   pt->rep.string.start=start;
1837   pt->rep.string.curr=start;
1838   pt->rep.string.past_the_end=past_the_end;
1839   return pt;
1840 }
1841
1842 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1843   port *pt;
1844   pt=port_rep_from_string(sc,start,past_the_end,prop);
1845   if(pt==0) {
1846     return sc->NIL;
1847   }
1848   return mk_port(sc,pt);
1849 }
1850
1851 #define BLOCK_SIZE 256
1852
1853 static port *port_rep_from_scratch(scheme *sc) {
1854   port *pt;
1855   char *start;
1856   pt=(port*)sc->malloc(sizeof(port));
1857   if(pt==0) {
1858     return 0;
1859   }
1860   start=sc->malloc(BLOCK_SIZE);
1861   if(start==0) {
1862     return 0;
1863   }
1864   memset(start,' ',BLOCK_SIZE-1);
1865   start[BLOCK_SIZE-1]='\0';
1866   pt->kind=port_string|port_output|port_srfi6;
1867   pt->rep.string.start=start;
1868   pt->rep.string.curr=start;
1869   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1870   return pt;
1871 }
1872
1873 static pointer port_from_scratch(scheme *sc) {
1874   port *pt;
1875   pt=port_rep_from_scratch(sc);
1876   if(pt==0) {
1877     return sc->NIL;
1878   }
1879   return mk_port(sc,pt);
1880 }
1881
1882 static void port_close(scheme *sc, pointer p, int flag) {
1883   port *pt=p->_object._port;
1884   pt->kind&=~flag;
1885   if((pt->kind & (port_input|port_output))==0) {
1886     if(pt->kind&port_file) {
1887
1888 #if SHOW_ERROR_LINE
1889       /* Cleanup is here so (close-*-port) functions could work too */
1890       port_clear_location(sc, pt);
1891 #endif
1892
1893       fclose(pt->rep.stdio.file);
1894     }
1895     pt->kind=port_free;
1896   }
1897 }
1898
1899 /* get new character from input file */
1900 static int inchar(scheme *sc) {
1901   int c;
1902   port *pt;
1903
1904   pt = sc->inport->_object._port;
1905   if(pt->kind & port_saw_EOF)
1906     { return EOF; }
1907   c = basic_inchar(pt);
1908   if(c == EOF && sc->inport == sc->loadport) {
1909     /* Instead, set port_saw_EOF */
1910     pt->kind |= port_saw_EOF;
1911
1912     /* file_pop(sc); */
1913     return EOF;
1914     /* NOTREACHED */
1915   }
1916   return c;
1917 }
1918
1919 static int basic_inchar(port *pt) {
1920   if(pt->kind & port_file) {
1921     return fgetc(pt->rep.stdio.file);
1922   } else {
1923     if(*pt->rep.string.curr == 0 ||
1924        pt->rep.string.curr == pt->rep.string.past_the_end) {
1925       return EOF;
1926     } else {
1927       return *pt->rep.string.curr++;
1928     }
1929   }
1930 }
1931
1932 /* back character to input buffer */
1933 static void backchar(scheme *sc, int c) {
1934   port *pt;
1935   if(c==EOF) return;
1936   pt=sc->inport->_object._port;
1937   if(pt->kind&port_file) {
1938     ungetc(c,pt->rep.stdio.file);
1939   } else {
1940     if(pt->rep.string.curr!=pt->rep.string.start) {
1941       --pt->rep.string.curr;
1942     }
1943   }
1944 }
1945
1946 static int realloc_port_string(scheme *sc, port *p)
1947 {
1948   char *start=p->rep.string.start;
1949   size_t old_size = p->rep.string.past_the_end - start;
1950   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1951   char *str=sc->malloc(new_size);
1952   if(str) {
1953     memset(str,' ',new_size-1);
1954     str[new_size-1]='\0';
1955     memcpy(str, start, old_size);
1956     p->rep.string.start=str;
1957     p->rep.string.past_the_end=str+new_size-1;
1958     p->rep.string.curr-=start-str;
1959     sc->free(start);
1960     return 1;
1961   } else {
1962     return 0;
1963   }
1964 }
1965
1966 INTERFACE void putstr(scheme *sc, const char *s) {
1967   port *pt=sc->outport->_object._port;
1968   if(pt->kind&port_file) {
1969     fputs(s,pt->rep.stdio.file);
1970   } else {
1971     for(;*s;s++) {
1972       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1973         *pt->rep.string.curr++=*s;
1974       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1975         *pt->rep.string.curr++=*s;
1976       }
1977     }
1978   }
1979 }
1980
1981 static void putchars(scheme *sc, const char *s, int len) {
1982   port *pt=sc->outport->_object._port;
1983   if(pt->kind&port_file) {
1984     fwrite(s,1,len,pt->rep.stdio.file);
1985   } else {
1986     for(;len;len--) {
1987       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1988         *pt->rep.string.curr++=*s++;
1989       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1990         *pt->rep.string.curr++=*s++;
1991       }
1992     }
1993   }
1994 }
1995
1996 INTERFACE void putcharacter(scheme *sc, int c) {
1997   port *pt=sc->outport->_object._port;
1998   if(pt->kind&port_file) {
1999     fputc(c,pt->rep.stdio.file);
2000   } else {
2001     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
2002       *pt->rep.string.curr++=c;
2003     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
2004         *pt->rep.string.curr++=c;
2005     }
2006   }
2007 }
2008
2009 /* read characters up to delimiter, but cater to character constants */
2010 static char *readstr_upto(scheme *sc, char *delim) {
2011   char *p = sc->strbuff;
2012
2013   while ((p - sc->strbuff < sc->strbuff_size) &&
2014          !is_one_of(delim, (*p++ = inchar(sc))));
2015
2016   if(p == sc->strbuff+2 && p[-2] == '\\') {
2017     *p=0;
2018   } else {
2019     backchar(sc,p[-1]);
2020     *--p = '\0';
2021   }
2022   return sc->strbuff;
2023 }
2024
2025 /* read string expression "xxx...xxx" */
2026 static pointer readstrexp(scheme *sc) {
2027   char *p = sc->strbuff;
2028   int c;
2029   int c1=0;
2030   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
2031
2032   for (;;) {
2033     c=inchar(sc);
2034     if(c == EOF) {
2035       return sc->F;
2036     }
2037     if(p-sc->strbuff > (sc->strbuff_size)-1) {
2038       ptrdiff_t offset = p - sc->strbuff;
2039       if (expand_strbuff(sc) != 0) {
2040         return sc->F;
2041       }
2042       p = sc->strbuff + offset;
2043     }
2044     switch(state) {
2045         case st_ok:
2046             switch(c) {
2047                 case '\\':
2048                     state=st_bsl;
2049                     break;
2050                 case '"':
2051                     *p=0;
2052                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
2053                 default:
2054                     *p++=c;
2055                     break;
2056             }
2057             break;
2058         case st_bsl:
2059             switch(c) {
2060                 case '0':
2061                 case '1':
2062                 case '2':
2063                 case '3':
2064                 case '4':
2065                 case '5':
2066                 case '6':
2067                 case '7':
2068                         state=st_oct1;
2069                         c1=c-'0';
2070                         break;
2071                 case 'x':
2072                 case 'X':
2073                     state=st_x1;
2074                     c1=0;
2075                     break;
2076                 case 'n':
2077                     *p++='\n';
2078                     state=st_ok;
2079                     break;
2080                 case 't':
2081                     *p++='\t';
2082                     state=st_ok;
2083                     break;
2084                 case 'r':
2085                     *p++='\r';
2086                     state=st_ok;
2087                     break;
2088                 case '"':
2089                     *p++='"';
2090                     state=st_ok;
2091                     break;
2092                 default:
2093                     *p++=c;
2094                     state=st_ok;
2095                     break;
2096             }
2097             break;
2098         case st_x1:
2099         case st_x2:
2100             c=toupper(c);
2101             if(c>='0' && c<='F') {
2102                 if(c<='9') {
2103                     c1=(c1<<4)+c-'0';
2104                 } else {
2105                     c1=(c1<<4)+c-'A'+10;
2106                 }
2107                 if(state==st_x1) {
2108                     state=st_x2;
2109                 } else {
2110                     *p++=c1;
2111                     state=st_ok;
2112                 }
2113             } else {
2114                 return sc->F;
2115             }
2116             break;
2117         case st_oct1:
2118         case st_oct2:
2119             if (c < '0' || c > '7')
2120             {
2121                    *p++=c1;
2122                    backchar(sc, c);
2123                    state=st_ok;
2124             }
2125             else
2126             {
2127                 if (state==st_oct2 && c1 >= 32)
2128                     return sc->F;
2129
2130                    c1=(c1<<3)+(c-'0');
2131
2132                 if (state == st_oct1)
2133                         state=st_oct2;
2134                 else
2135                 {
2136                         *p++=c1;
2137                         state=st_ok;
2138                    }
2139             }
2140             break;
2141
2142     }
2143   }
2144 }
2145
2146 /* check c is in chars */
2147 static INLINE int is_one_of(char *s, int c) {
2148      if(c==EOF) return 1;
2149      while (*s)
2150           if (*s++ == c)
2151                return (1);
2152      return (0);
2153 }
2154
2155 /* skip white characters */
2156 static INLINE int skipspace(scheme *sc) {
2157      int c = 0, curr_line = 0;
2158
2159      do {
2160          c=inchar(sc);
2161 #if SHOW_ERROR_LINE
2162          if(c=='\n')
2163            curr_line++;
2164 #endif
2165      } while (isspace(c));
2166
2167 /* record it */
2168 #if SHOW_ERROR_LINE
2169      {
2170        port *p = &sc->load_stack[sc->file_i];
2171        if (p->kind & port_file)
2172          port_increment_current_line(sc, p, curr_line);
2173      }
2174 #endif
2175
2176      if(c!=EOF) {
2177           backchar(sc,c);
2178       return 1;
2179      }
2180      else
2181        { return EOF; }
2182 }
2183
2184 /* get token */
2185 static int token(scheme *sc) {
2186      int c;
2187      c = skipspace(sc);
2188      if(c == EOF) { return (TOK_EOF); }
2189      switch (c=inchar(sc)) {
2190      case EOF:
2191           return (TOK_EOF);
2192      case '(':
2193           return (TOK_LPAREN);
2194      case ')':
2195           return (TOK_RPAREN);
2196      case '.':
2197           c=inchar(sc);
2198           if(is_one_of(" \n\t",c)) {
2199                return (TOK_DOT);
2200           } else {
2201                backchar(sc,c);
2202                backchar(sc,'.');
2203                return TOK_ATOM;
2204           }
2205      case '\'':
2206           return (TOK_QUOTE);
2207      case ';':
2208            while ((c=inchar(sc)) != '\n' && c!=EOF)
2209              ;
2210
2211 #if SHOW_ERROR_LINE
2212            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2213              port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
2214 #endif
2215
2216        if(c == EOF)
2217          { return (TOK_EOF); }
2218        else
2219          { return (token(sc));}
2220      case '"':
2221           return (TOK_DQUOTE);
2222      case BACKQUOTE:
2223           return (TOK_BQUOTE);
2224      case ',':
2225          if ((c=inchar(sc)) == '@') {
2226                return (TOK_ATMARK);
2227          } else {
2228                backchar(sc,c);
2229                return (TOK_COMMA);
2230          }
2231      case '#':
2232           c=inchar(sc);
2233           if (c == '(') {
2234                return (TOK_VEC);
2235           } else if(c == '!') {
2236                while ((c=inchar(sc)) != '\n' && c!=EOF)
2237                    ;
2238
2239 #if SHOW_ERROR_LINE
2240            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2241              port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
2242 #endif
2243
2244            if(c == EOF)
2245              { return (TOK_EOF); }
2246            else
2247              { return (token(sc));}
2248           } else {
2249                backchar(sc,c);
2250                if(is_one_of(" tfodxb\\",c)) {
2251                     return TOK_SHARP_CONST;
2252                } else {
2253                     return (TOK_SHARP);
2254                }
2255           }
2256      default:
2257           backchar(sc,c);
2258           return (TOK_ATOM);
2259      }
2260 }
2261
2262 /* ========== Routines for Printing ========== */
2263 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
2264
2265 static void printslashstring(scheme *sc, char *p, int len) {
2266   int i;
2267   unsigned char *s=(unsigned char*)p;
2268   putcharacter(sc,'"');
2269   for ( i=0; i<len; i++) {
2270     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
2271       putcharacter(sc,'\\');
2272       switch(*s) {
2273       case '"':
2274         putcharacter(sc,'"');
2275         break;
2276       case '\n':
2277         putcharacter(sc,'n');
2278         break;
2279       case '\t':
2280         putcharacter(sc,'t');
2281         break;
2282       case '\r':
2283         putcharacter(sc,'r');
2284         break;
2285       case '\\':
2286         putcharacter(sc,'\\');
2287         break;
2288       default: {
2289           int d=*s/16;
2290           putcharacter(sc,'x');
2291           if(d<10) {
2292             putcharacter(sc,d+'0');
2293           } else {
2294             putcharacter(sc,d-10+'A');
2295           }
2296           d=*s%16;
2297           if(d<10) {
2298             putcharacter(sc,d+'0');
2299           } else {
2300             putcharacter(sc,d-10+'A');
2301           }
2302         }
2303       }
2304     } else {
2305       putcharacter(sc,*s);
2306     }
2307     s++;
2308   }
2309   putcharacter(sc,'"');
2310 }
2311
2312
2313 /* print atoms */
2314 static void printatom(scheme *sc, pointer l, int f) {
2315   char *p;
2316   int len;
2317   atom2str(sc,l,f,&p,&len);
2318   putchars(sc,p,len);
2319 }
2320
2321
2322 /* Uses internal buffer unless string pointer is already available */
2323 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2324      char *p;
2325
2326      if (l == sc->NIL) {
2327           p = "()";
2328      } else if (l == sc->T) {
2329           p = "#t";
2330      } else if (l == sc->F) {
2331           p = "#f";
2332      } else if (l == sc->EOF_OBJ) {
2333           p = "#<EOF>";
2334      } else if (is_port(l)) {
2335           p = "#<PORT>";
2336      } else if (is_number(l)) {
2337           p = sc->strbuff;
2338           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2339               if(num_is_integer(l)) {
2340                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2341               } else {
2342                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2343                    /* r5rs says there must be a '.' (unless 'e'?) */
2344                    f = strcspn(p, ".e");
2345                    if (p[f] == 0) {
2346                         p[f] = '.'; /* not found, so add '.0' at the end */
2347                         p[f+1] = '0';
2348                         p[f+2] = 0;
2349                    }
2350               }
2351           } else {
2352               long v = ivalue(l);
2353               if (f == 16) {
2354                   if (v >= 0)
2355                     snprintf(p, STRBUFFSIZE, "%lx", v);
2356                   else
2357                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2358               } else if (f == 8) {
2359                   if (v >= 0)
2360                     snprintf(p, STRBUFFSIZE, "%lo", v);
2361                   else
2362                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2363               } else if (f == 2) {
2364                   unsigned long b = (v < 0) ? -v : v;
2365                   p = &p[STRBUFFSIZE-1];
2366                   *p = 0;
2367                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2368                   if (v < 0) *--p = '-';
2369               }
2370           }
2371      } else if (is_string(l)) {
2372           if (!f) {
2373                *pp = strvalue(l);
2374                *plen = strlength(l);
2375                return;
2376           } else { /* Hack, uses the fact that printing is needed */
2377                *pp=sc->strbuff;
2378                *plen=0;
2379                printslashstring(sc, strvalue(l), strlength(l));
2380                return;
2381           }
2382      } else if (is_character(l)) {
2383           int c=charvalue(l);
2384           p = sc->strbuff;
2385           if (!f) {
2386                p[0]=c;
2387                p[1]=0;
2388           } else {
2389                switch(c) {
2390                case ' ':
2391                     p = "#\\space";
2392                     break;
2393                case '\n':
2394                     p = "#\\newline";
2395                     break;
2396                case '\r':
2397                     p = "#\\return";
2398                     break;
2399                case '\t':
2400                     p = "#\\tab";
2401                     break;
2402                default:
2403 #if USE_ASCII_NAMES
2404                     if(c==127) {
2405                          p = "#\\del";
2406                          break;
2407                     } else if(c<32) {
2408                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2409                          break;
2410                     }
2411 #else
2412                     if(c<32) {
2413                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2414                       break;
2415                     }
2416 #endif
2417                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2418                     break;
2419                }
2420           }
2421      } else if (is_symbol(l)) {
2422           p = symname(l);
2423      } else if (is_proc(l)) {
2424           p = sc->strbuff;
2425           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2426      } else if (is_macro(l)) {
2427           p = "#<MACRO>";
2428      } else if (is_closure(l)) {
2429           p = "#<CLOSURE>";
2430      } else if (is_promise(l)) {
2431           p = "#<PROMISE>";
2432      } else if (is_foreign(l)) {
2433           p = sc->strbuff;
2434           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2435      } else if (is_continuation(l)) {
2436           p = "#<CONTINUATION>";
2437      } else if (is_foreign_object(l)) {
2438           p = sc->strbuff;
2439           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2440      } else {
2441           p = "#<ERROR>";
2442      }
2443      *pp=p;
2444      *plen=strlen(p);
2445 }
2446 /* ========== Routines for Evaluation Cycle ========== */
2447
2448 /* make closure. c is code. e is environment */
2449 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2450      pointer x = get_cell(sc, c, e);
2451
2452      typeflag(x) = T_CLOSURE;
2453      car(x) = c;
2454      cdr(x) = e;
2455      return (x);
2456 }
2457
2458 /* make continuation. */
2459 static pointer mk_continuation(scheme *sc, pointer d) {
2460      pointer x = get_cell(sc, sc->NIL, d);
2461
2462      typeflag(x) = T_CONTINUATION;
2463      cont_dump(x) = d;
2464      return (x);
2465 }
2466
2467 static pointer list_star(scheme *sc, pointer d) {
2468   pointer p, q;
2469   if(cdr(d)==sc->NIL) {
2470     return car(d);
2471   }
2472   p=cons(sc,car(d),cdr(d));
2473   q=p;
2474   while(cdr(cdr(p))!=sc->NIL) {
2475     d=cons(sc,car(p),cdr(p));
2476     if(cdr(cdr(p))!=sc->NIL) {
2477       p=cdr(d);
2478     }
2479   }
2480   cdr(p)=car(cdr(p));
2481   return q;
2482 }
2483
2484 /* reverse list -- produce new list */
2485 static pointer reverse(scheme *sc, pointer term, pointer list) {
2486 /* a must be checked by gc */
2487      pointer a = list, p = term;
2488
2489      for ( ; is_pair(a); a = cdr(a)) {
2490           p = cons(sc, car(a), p);
2491      }
2492      return (p);
2493 }
2494
2495 /* reverse list --- in-place */
2496 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2497      pointer p = list, result = term, q;
2498
2499      while (p != sc->NIL) {
2500           q = cdr(p);
2501           cdr(p) = result;
2502           result = p;
2503           p = q;
2504      }
2505      return (result);
2506 }
2507
2508 /* append list -- produce new list (in reverse order) */
2509 static pointer revappend(scheme *sc, pointer a, pointer b) {
2510     pointer result = a;
2511     pointer p = b;
2512
2513     while (is_pair(p)) {
2514         result = cons(sc, car(p), result);
2515         p = cdr(p);
2516     }
2517
2518     if (p == sc->NIL) {
2519         return result;
2520     }
2521
2522     return sc->F;   /* signal an error */
2523 }
2524
2525 /* equivalence of atoms */
2526 int eqv(pointer a, pointer b) {
2527      if (is_string(a)) {
2528           if (is_string(b))
2529                return (strvalue(a) == strvalue(b));
2530           else
2531                return (0);
2532      } else if (is_number(a)) {
2533           if (is_number(b)) {
2534                if (num_is_integer(a) == num_is_integer(b))
2535                     return num_eq(nvalue(a),nvalue(b));
2536           }
2537           return (0);
2538      } else if (is_character(a)) {
2539           if (is_character(b))
2540                return charvalue(a)==charvalue(b);
2541           else
2542                return (0);
2543      } else if (is_port(a)) {
2544           if (is_port(b))
2545                return a==b;
2546           else
2547                return (0);
2548      } else if (is_proc(a)) {
2549           if (is_proc(b))
2550                return procnum(a)==procnum(b);
2551           else
2552                return (0);
2553      } else {
2554           return (a == b);
2555      }
2556 }
2557
2558 /* true or false value macro */
2559 /* () is #t in R5RS */
2560 #define is_true(p)       ((p) != sc->F)
2561 #define is_false(p)      ((p) == sc->F)
2562
2563 /* ========== Environment implementation  ========== */
2564
2565 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2566
2567 static int hash_fn(const char *key, int table_size)
2568 {
2569   unsigned int hashed = 0;
2570   const char *c;
2571   int bits_per_int = sizeof(unsigned int)*8;
2572
2573   for (c = key; *c; c++) {
2574     /* letters have about 5 bits in them */
2575     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2576     hashed ^= *c;
2577   }
2578   return hashed % table_size;
2579 }
2580 #endif
2581
2582 #ifndef USE_ALIST_ENV
2583
2584 /*
2585  * In this implementation, each frame of the environment may be
2586  * a hash table: a vector of alists hashed by variable name.
2587  * In practice, we use a vector only for the initial frame;
2588  * subsequent frames are too small and transient for the lookup
2589  * speed to out-weigh the cost of making a new vector.
2590  */
2591
2592 static void new_frame_in_env(scheme *sc, pointer old_env)
2593 {
2594   pointer new_frame;
2595
2596   /* The interaction-environment has about 300 variables in it. */
2597   if (old_env == sc->NIL) {
2598     new_frame = mk_vector(sc, 461);
2599   } else {
2600     new_frame = sc->NIL;
2601   }
2602
2603   gc_disable(sc, 1);
2604   sc->envir = immutable_cons(sc, new_frame, old_env);
2605   gc_enable(sc);
2606   setenvironment(sc->envir);
2607 }
2608
2609 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2610                                         pointer variable, pointer value)
2611 {
2612 #define new_slot_spec_in_env_allocates  2
2613   pointer slot;
2614   gc_disable(sc, gc_reservations (new_slot_spec_in_env));
2615   slot = immutable_cons(sc, variable, value);
2616
2617   if (is_vector(car(env))) {
2618     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2619
2620     set_vector_elem(car(env), location,
2621                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2622   } else {
2623     car(env) = immutable_cons(sc, slot, car(env));
2624   }
2625   gc_enable(sc);
2626 }
2627
2628 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2629 {
2630   pointer x,y;
2631   int location;
2632
2633   for (x = env; x != sc->NIL; x = cdr(x)) {
2634     if (is_vector(car(x))) {
2635       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2636       y = vector_elem(car(x), location);
2637     } else {
2638       y = car(x);
2639     }
2640     for ( ; y != sc->NIL; y = cdr(y)) {
2641               if (caar(y) == hdl) {
2642                    break;
2643               }
2644          }
2645          if (y != sc->NIL) {
2646               break;
2647          }
2648          if(!all) {
2649            return sc->NIL;
2650          }
2651     }
2652     if (x != sc->NIL) {
2653           return car(y);
2654     }
2655     return sc->NIL;
2656 }
2657
2658 #else /* USE_ALIST_ENV */
2659
2660 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2661 {
2662   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2663   setenvironment(sc->envir);
2664 }
2665
2666 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2667                                         pointer variable, pointer value)
2668 {
2669   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2670 }
2671
2672 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2673 {
2674     pointer x,y;
2675     for (x = env; x != sc->NIL; x = cdr(x)) {
2676          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2677               if (caar(y) == hdl) {
2678                    break;
2679               }
2680          }
2681          if (y != sc->NIL) {
2682               break;
2683          }
2684          if(!all) {
2685            return sc->NIL;
2686          }
2687     }
2688     if (x != sc->NIL) {
2689           return car(y);
2690     }
2691     return sc->NIL;
2692 }
2693
2694 #endif /* USE_ALIST_ENV else */
2695
2696 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2697 {
2698 #define new_slot_in_env_allocates       new_slot_spec_in_env_allocates
2699   new_slot_spec_in_env(sc, sc->envir, variable, value);
2700 }
2701
2702 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2703 {
2704   (void)sc;
2705   cdr(slot) = value;
2706 }
2707
2708 static INLINE pointer slot_value_in_env(pointer slot)
2709 {
2710   return cdr(slot);
2711 }
2712
2713 /* ========== Evaluation Cycle ========== */
2714
2715
2716 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2717      const char *str = s;
2718      pointer history;
2719 #if USE_ERROR_HOOK
2720      pointer x;
2721      pointer hdl=sc->ERROR_HOOK;
2722 #endif
2723
2724 #if SHOW_ERROR_LINE
2725      char sbuf[STRBUFFSIZE];
2726 #endif
2727
2728      history = history_flatten(sc);
2729
2730 #if SHOW_ERROR_LINE
2731      /* make sure error is not in REPL */
2732      if (sc->load_stack[sc->file_i].kind & port_file &&
2733          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2734        pointer tag;
2735        const char *fname;
2736        int ln;
2737
2738        if (history != sc->NIL && has_tag(car(history))
2739            && (tag = get_tag(sc, car(history)))
2740            && is_string(car(tag)) && is_integer(cdr(tag))) {
2741          fname = string_value(car(tag));
2742          ln = ivalue_unchecked(cdr(tag));
2743        } else {
2744          fname = string_value(sc->load_stack[sc->file_i].rep.stdio.filename);
2745          ln = ivalue_unchecked(sc->load_stack[sc->file_i].rep.stdio.curr_line);
2746        }
2747
2748        /* should never happen */
2749        if(!fname) fname = "<unknown>";
2750
2751        /* we started from 0 */
2752        ln++;
2753        snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
2754
2755        str = (const char*)sbuf;
2756      }
2757 #endif
2758
2759 #if USE_ERROR_HOOK
2760      x=find_slot_in_env(sc,sc->envir,hdl,1);
2761     if (x != sc->NIL) {
2762          sc->code = cons(sc, cons(sc, sc->QUOTE,
2763                                   cons(sc, history, sc->NIL)),
2764                          sc->NIL);
2765          if(a!=0) {
2766            sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
2767                            sc->code);
2768          } else {
2769            sc->code = cons(sc, sc->F, sc->code);
2770          }
2771          sc->code = cons(sc, mk_string(sc, str), sc->code);
2772          setimmutable(car(sc->code));
2773          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2774          sc->op = (int)OP_EVAL;
2775          return sc->T;
2776     }
2777 #endif
2778
2779     if(a!=0) {
2780           sc->args = cons(sc, (a), sc->NIL);
2781     } else {
2782           sc->args = sc->NIL;
2783     }
2784     sc->args = cons(sc, mk_string(sc, str), sc->args);
2785     setimmutable(car(sc->args));
2786     sc->op = (int)OP_ERR0;
2787     return sc->T;
2788 }
2789 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2790 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2791
2792 /* Too small to turn into function */
2793 # define  BEGIN     do {
2794 # define  END  } while (0)
2795
2796 \f
2797
2798 /* Flags.  The interpreter has a flags field.  When the interpreter
2799  * pushes a frame to the dump stack, it is encoded with the opcode.
2800  * Therefore, we do not use the least significant byte.  */
2801
2802 /* Masks used to encode and decode opcode and flags.  */
2803 #define S_OP_MASK       0x000000ff
2804 #define S_FLAG_MASK     0xffffff00
2805
2806 /* Set if the interpreter evaluates an expression in a tail context
2807  * (see R5RS, section 3.5).  If a function, procedure, or continuation
2808  * is invoked while this flag is set, the call is recorded as tail
2809  * call in the history buffer.  */
2810 #define S_FLAG_TAIL_CONTEXT     0x00000100
2811
2812 /* Set flag F.  */
2813 #define s_set_flag(sc, f)                       \
2814            BEGIN                                \
2815            (sc)->flags |= S_FLAG_ ## f;         \
2816            END
2817
2818 /* Clear flag F.  */
2819 #define s_clear_flag(sc, f)                     \
2820            BEGIN                                \
2821            (sc)->flags &= ~ S_FLAG_ ## f;       \
2822            END
2823
2824 /* Check if flag F is set.  */
2825 #define s_get_flag(sc, f)                       \
2826            !!((sc)->flags & S_FLAG_ ## f)
2827
2828 \f
2829
2830 /* Bounce back to Eval_Cycle and execute A.  */
2831 #define s_goto(sc,a) BEGIN                                  \
2832     sc->op = (int)(a);                                      \
2833     return sc->T; END
2834
2835 #if USE_THREADED_CODE
2836
2837 /* Do not bounce back to Eval_Cycle but execute A by jumping directly
2838  * to it.  Only applicable if A is part of the same dispatch
2839  * function.  */
2840 #define s_thread_to(sc, a)      \
2841      BEGIN                      \
2842      op = (int) (a);            \
2843      goto a;                    \
2844      END
2845
2846 /* Define a label OP and emit a case statement for OP.  For use in the
2847  * dispatch functions.  The slightly peculiar goto that is never
2848  * executed avoids warnings about unused labels.  */
2849 #define CASE(OP)        if (0) goto OP; OP: case OP
2850
2851 #else   /* USE_THREADED_CODE */
2852 #define s_thread_to(sc, a)      s_goto(sc, a)
2853 #define CASE(OP)                case OP
2854 #endif  /* USE_THREADED_CODE */
2855
2856 /* Return to the previous frame on the dump stack, setting the current
2857  * value to A.  */
2858 #define s_return(sc, a) return _s_return(sc, a, 0)
2859
2860 /* Return to the previous frame on the dump stack, setting the current
2861  * value to A, and re-enable the garbage collector.  */
2862 #define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
2863
2864 static INLINE void dump_stack_reset(scheme *sc)
2865 {
2866   sc->dump = sc->NIL;
2867 }
2868
2869 static INLINE void dump_stack_initialize(scheme *sc)
2870 {
2871   dump_stack_reset(sc);
2872 }
2873
2874 static void dump_stack_free(scheme *sc)
2875 {
2876   sc->dump = sc->NIL;
2877 }
2878
2879 static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
2880   pointer dump = sc->dump;
2881   pointer op;
2882   unsigned long v;
2883   sc->value = (a);
2884   if (enable_gc)
2885        gc_enable(sc);
2886   if (dump == sc->NIL)
2887     return sc->NIL;
2888   free_cons(sc, dump, &op, &dump);
2889   v = (unsigned long) ivalue_unchecked(op);
2890   sc->op = (int) (v & S_OP_MASK);
2891   sc->flags = v & S_FLAG_MASK;
2892 #ifdef USE_SMALL_INTEGERS
2893   if (v < MAX_SMALL_INTEGER) {
2894     /* This is a small integer, we must not free it.  */
2895   } else
2896     /* Normal integer.  Recover the cell.  */
2897 #endif
2898     free_cell(sc, op);
2899   free_cons(sc, dump, &sc->args, &dump);
2900   free_cons(sc, dump, &sc->envir, &dump);
2901   free_cons(sc, dump, &sc->code, &sc->dump);
2902   return sc->T;
2903 }
2904
2905 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2906 #define s_save_allocates        5
2907     pointer dump;
2908     unsigned long v = sc->flags | ((unsigned long) op);
2909     gc_disable(sc, gc_reservations (s_save));
2910     dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2911     dump = cons(sc, (args), dump);
2912     sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
2913     gc_enable(sc);
2914 }
2915
2916 static INLINE void dump_stack_mark(scheme *sc)
2917 {
2918   mark(sc->dump);
2919 }
2920
2921 \f
2922
2923 #if USE_HISTORY
2924
2925 static void
2926 history_free(scheme *sc)
2927 {
2928   sc->free(sc->history.m);
2929   sc->history.tailstacks = sc->NIL;
2930   sc->history.callstack = sc->NIL;
2931 }
2932
2933 static pointer
2934 history_init(scheme *sc, size_t N, size_t M)
2935 {
2936   size_t i;
2937   struct history *h = &sc->history;
2938
2939   h->N = N;
2940   h->mask_N = N - 1;
2941   h->n = N - 1;
2942   assert ((N & h->mask_N) == 0);
2943
2944   h->M = M;
2945   h->mask_M = M - 1;
2946   assert ((M & h->mask_M) == 0);
2947
2948   h->callstack = mk_vector(sc, N);
2949   if (h->callstack == sc->sink)
2950     goto fail;
2951
2952   h->tailstacks = mk_vector(sc, N);
2953   for (i = 0; i < N; i++) {
2954     pointer tailstack = mk_vector(sc, M);
2955     if (tailstack == sc->sink)
2956       goto fail;
2957     set_vector_elem(h->tailstacks, i, tailstack);
2958   }
2959
2960   h->m = sc->malloc(N * sizeof *h->m);
2961   if (h->m == NULL)
2962     goto fail;
2963
2964   for (i = 0; i < N; i++)
2965     h->m[i] = 0;
2966
2967   return sc->T;
2968
2969 fail:
2970   history_free(sc);
2971   return sc->F;
2972 }
2973
2974 static void
2975 history_mark(scheme *sc)
2976 {
2977   struct history *h = &sc->history;
2978   mark(h->callstack);
2979   mark(h->tailstacks);
2980 }
2981
2982 #define add_mod(a, b, mask)     (((a) + (b)) & (mask))
2983 #define sub_mod(a, b, mask)     add_mod(a, (mask) + 1 - (b), mask)
2984
2985 static INLINE void
2986 tailstack_clear(scheme *sc, pointer v)
2987 {
2988   assert(is_vector(v));
2989   /* XXX optimize */
2990   fill_vector(v, sc->NIL);
2991 }
2992
2993 static pointer
2994 callstack_pop(scheme *sc)
2995 {
2996   struct history *h = &sc->history;
2997   size_t n = h->n;
2998   pointer item;
2999
3000   if (h->callstack == sc->NIL)
3001     return sc->NIL;
3002
3003   item = vector_elem(h->callstack, n);
3004   /* Clear our frame so that it can be gc'ed and we don't run into it
3005    * when walking the history.  */
3006   set_vector_elem(h->callstack, n, sc->NIL);
3007   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3008
3009   /* Exit from the frame.  */
3010   h->n = sub_mod(h->n, 1, h->mask_N);
3011
3012   return item;
3013 }
3014
3015 static void
3016 callstack_push(scheme *sc, pointer item)
3017 {
3018   struct history *h = &sc->history;
3019   size_t n = h->n;
3020
3021   if (h->callstack == sc->NIL)
3022     return;
3023
3024   /* Enter a new frame.  */
3025   n = h->n = add_mod(n, 1, h->mask_N);
3026
3027   /* Initialize tail stack.  */
3028   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3029   h->m[n] = h->mask_M;
3030
3031   set_vector_elem(h->callstack, n, item);
3032 }
3033
3034 static void
3035 tailstack_push(scheme *sc, pointer item)
3036 {
3037   struct history *h = &sc->history;
3038   size_t n = h->n;
3039   size_t m = h->m[n];
3040
3041   if (h->callstack == sc->NIL)
3042     return;
3043
3044   /* Enter a new tail frame.  */
3045   m = h->m[n] = add_mod(m, 1, h->mask_M);
3046   set_vector_elem(vector_elem(h->tailstacks, n), m, item);
3047 }
3048
3049 static pointer
3050 tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
3051                   pointer acc)
3052 {
3053   struct history *h = &sc->history;
3054   pointer frame;
3055
3056   assert(i <= h->M);
3057   assert(n < h->M);
3058
3059   if (acc == sc->sink)
3060     return sc->sink;
3061
3062   if (i == 0) {
3063     /* We reached the end, but we did not see a unused frame.  Signal
3064        this using '... .  */
3065     return cons(sc, mk_symbol(sc, "..."), acc);
3066   }
3067
3068   frame = vector_elem(tailstack, n);
3069   if (frame == sc->NIL) {
3070     /* A unused frame.  We reached the end of the history.  */
3071     return acc;
3072   }
3073
3074   /* Add us.  */
3075   acc = cons(sc, frame, acc);
3076
3077   return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
3078                            acc);
3079 }
3080
3081 static pointer
3082 callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
3083 {
3084   struct history *h = &sc->history;
3085   pointer frame;
3086
3087   assert(i <= h->N);
3088   assert(n < h->N);
3089
3090   if (acc == sc->sink)
3091     return sc->sink;
3092
3093   if (i == 0) {
3094     /* We reached the end, but we did not see a unused frame.  Signal
3095        this using '... .  */
3096     return cons(sc, mk_symbol(sc, "..."), acc);
3097   }
3098
3099   frame = vector_elem(h->callstack, n);
3100   if (frame == sc->NIL) {
3101     /* A unused frame.  We reached the end of the history.  */
3102     return acc;
3103   }
3104
3105   /* First, emit the tail calls.  */
3106   acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
3107                           acc);
3108
3109   /* Then us.  */
3110   acc = cons(sc, frame, acc);
3111
3112   return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
3113 }
3114
3115 static pointer
3116 history_flatten(scheme *sc)
3117 {
3118   struct history *h = &sc->history;
3119   pointer history;
3120
3121   if (h->callstack == sc->NIL)
3122     return sc->NIL;
3123
3124   history = callstack_flatten(sc, h->N, h->n, sc->NIL);
3125   if (history == sc->sink)
3126     return sc->sink;
3127
3128   return reverse_in_place(sc, sc->NIL, history);
3129 }
3130
3131 #undef add_mod
3132 #undef sub_mod
3133
3134 #else   /* USE_HISTORY */
3135
3136 #define history_init(SC, A, B)  (void) 0
3137 #define history_free(SC)        (void) 0
3138 #define callstack_pop(SC)       (void) 0
3139 #define callstack_push(SC, X)   (void) 0
3140 #define tailstack_push(SC, X)   (void) 0
3141
3142 #endif  /* USE_HISTORY */
3143
3144 \f
3145
3146 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
3147
3148 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
3149      pointer x, y;
3150      pointer callsite;
3151
3152      switch (op) {
3153      CASE(OP_LOAD):       /* load */
3154           if(file_interactive(sc)) {
3155                fprintf(sc->outport->_object._port->rep.stdio.file,
3156                "Loading %s\n", strvalue(car(sc->args)));
3157           }
3158           if (!file_push(sc, car(sc->args))) {
3159                Error_1(sc,"unable to open", car(sc->args));
3160           }
3161       else
3162         {
3163           sc->args = mk_integer(sc,sc->file_i);
3164           s_thread_to(sc,OP_T0LVL);
3165         }
3166
3167      CASE(OP_T0LVL): /* top level */
3168        /* If we reached the end of file, this loop is done. */
3169        if(sc->loadport->_object._port->kind & port_saw_EOF)
3170      {
3171        if(sc->file_i == 0)
3172          {
3173            sc->args=sc->NIL;
3174            sc->nesting = sc->nesting_stack[0];
3175            s_goto(sc,OP_QUIT);
3176          }
3177        else
3178          {
3179            file_pop(sc);
3180            s_return(sc,sc->value);
3181          }
3182        /* NOTREACHED */
3183      }
3184
3185        /* If interactive, be nice to user. */
3186        if(file_interactive(sc))
3187      {
3188        sc->envir = sc->global_env;
3189        dump_stack_reset(sc);
3190        putstr(sc,"\n");
3191        putstr(sc,prompt);
3192      }
3193
3194        /* Set up another iteration of REPL */
3195        sc->nesting=0;
3196        sc->save_inport=sc->inport;
3197        sc->inport = sc->loadport;
3198        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
3199        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
3200        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
3201        s_thread_to(sc,OP_READ_INTERNAL);
3202
3203      CASE(OP_T1LVL): /* top level */
3204           sc->code = sc->value;
3205           sc->inport=sc->save_inport;
3206           s_thread_to(sc,OP_EVAL);
3207
3208      CASE(OP_READ_INTERNAL):       /* internal read */
3209           sc->tok = token(sc);
3210           if(sc->tok==TOK_EOF)
3211         { s_return(sc,sc->EOF_OBJ); }
3212           s_goto(sc,OP_RDSEXPR);
3213
3214      CASE(OP_GENSYM):
3215           s_return(sc, gensym(sc));
3216
3217      CASE(OP_VALUEPRINT): /* print evaluation result */
3218           /* OP_VALUEPRINT is always pushed, because when changing from
3219              non-interactive to interactive mode, it needs to be
3220              already on the stack */
3221        if(sc->tracing) {
3222          putstr(sc,"\nGives: ");
3223        }
3224        if(file_interactive(sc)) {
3225          sc->print_flag = 1;
3226          sc->args = sc->value;
3227          s_goto(sc,OP_P0LIST);
3228        } else {
3229          s_return(sc,sc->value);
3230        }
3231
3232      CASE(OP_EVAL):       /* main part of evaluation */
3233 #if USE_TRACING
3234        if(sc->tracing) {
3235          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
3236          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
3237          sc->args=sc->code;
3238          putstr(sc,"\nEval: ");
3239          s_goto(sc,OP_P0LIST);
3240        }
3241        /* fall through */
3242      CASE(OP_REAL_EVAL):
3243 #endif
3244           if (is_symbol(sc->code)) {    /* symbol */
3245                x=find_slot_in_env(sc,sc->envir,sc->code,1);
3246                if (x != sc->NIL) {
3247                     s_return(sc,slot_value_in_env(x));
3248                } else {
3249                     Error_1(sc,"eval: unbound variable:", sc->code);
3250                }
3251           } else if (is_pair(sc->code)) {
3252                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
3253                     sc->code = cdr(sc->code);
3254                     s_goto(sc,syntaxnum(x));
3255                } else {/* first, eval top element and eval arguments */
3256                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
3257                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
3258                     sc->code = car(sc->code);
3259                     s_clear_flag(sc, TAIL_CONTEXT);
3260                     s_thread_to(sc,OP_EVAL);
3261                }
3262           } else {
3263                s_return(sc,sc->code);
3264           }
3265
3266      CASE(OP_E0ARGS):     /* eval arguments */
3267           if (is_macro(sc->value)) {    /* macro expansion */
3268                gc_disable(sc, 1 + gc_reservations (s_save));
3269                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
3270                sc->args = cons(sc,sc->code, sc->NIL);
3271                gc_enable(sc);
3272                sc->code = sc->value;
3273                s_clear_flag(sc, TAIL_CONTEXT);
3274                s_thread_to(sc,OP_APPLY);
3275           } else {
3276                gc_disable(sc, 1);
3277                sc->args = cons(sc, sc->code, sc->NIL);
3278                gc_enable(sc);
3279                sc->code = cdr(sc->code);
3280                s_thread_to(sc,OP_E1ARGS);
3281           }
3282
3283      CASE(OP_E1ARGS):     /* eval arguments */
3284           gc_disable(sc, 1);
3285           sc->args = cons(sc, sc->value, sc->args);
3286           gc_enable(sc);
3287           if (is_pair(sc->code)) { /* continue */
3288                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
3289                sc->code = car(sc->code);
3290                sc->args = sc->NIL;
3291                s_clear_flag(sc, TAIL_CONTEXT);
3292                s_thread_to(sc,OP_EVAL);
3293           } else {  /* end */
3294                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3295                s_thread_to(sc,OP_APPLY_CODE);
3296           }
3297
3298 #if USE_TRACING
3299      CASE(OP_TRACING): {
3300        int tr=sc->tracing;
3301        sc->tracing=ivalue(car(sc->args));
3302        gc_disable(sc, 1);
3303        s_return_enable_gc(sc, mk_integer(sc, tr));
3304      }
3305 #endif
3306
3307 #if USE_HISTORY
3308      CASE(OP_CALLSTACK_POP):      /* pop the call stack */
3309           callstack_pop(sc);
3310           s_return(sc, sc->value);
3311 #endif
3312
3313      CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
3314                            * record in the history as invoked from
3315                            * 'car(args)' */
3316           free_cons(sc, sc->args, &callsite, &sc->args);
3317           sc->code = car(sc->args);
3318           sc->args = cdr(sc->args);
3319           /* Fallthrough.  */
3320
3321      CASE(OP_APPLY):      /* apply 'code' to 'args' */
3322 #if USE_TRACING
3323        if(sc->tracing) {
3324          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
3325          sc->print_flag = 1;
3326          /*  sc->args=cons(sc,sc->code,sc->args);*/
3327          putstr(sc,"\nApply to: ");
3328          s_goto(sc,OP_P0LIST);
3329        }
3330        /* fall through */
3331      CASE(OP_REAL_APPLY):
3332 #endif
3333 #if USE_HISTORY
3334           if (op != OP_APPLY_CODE)
3335             callsite = sc->code;
3336           if (s_get_flag(sc, TAIL_CONTEXT)) {
3337             /* We are evaluating a tail call.  */
3338             tailstack_push(sc, callsite);
3339           } else {
3340             callstack_push(sc, callsite);
3341             s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
3342           }
3343 #endif
3344
3345           if (is_proc(sc->code)) {
3346                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
3347           } else if (is_foreign(sc->code))
3348             {
3349               /* Keep nested calls from GC'ing the arglist */
3350               push_recent_alloc(sc,sc->args,sc->NIL);
3351                x=sc->code->_object._ff(sc,sc->args);
3352                s_return(sc,x);
3353           } else if (is_closure(sc->code) || is_macro(sc->code)
3354              || is_promise(sc->code)) { /* CLOSURE */
3355         /* Should not accept promise */
3356                /* make environment */
3357                new_frame_in_env(sc, closure_env(sc->code));
3358                for (x = car(closure_code(sc->code)), y = sc->args;
3359                     is_pair(x); x = cdr(x), y = cdr(y)) {
3360                     if (y == sc->NIL) {
3361                          Error_1(sc, "not enough arguments, missing:", x);
3362                     } else {
3363                          new_slot_in_env(sc, car(x), car(y));
3364                     }
3365                }
3366                if (x == sc->NIL) {
3367                     if (y != sc->NIL) {
3368                       Error_0(sc, "too many arguments");
3369                     }
3370                } else if (is_symbol(x))
3371                     new_slot_in_env(sc, x, y);
3372                else {
3373                     Error_1(sc,"syntax error in closure: not a symbol:", x);
3374                }
3375                sc->code = cdr(closure_code(sc->code));
3376                sc->args = sc->NIL;
3377                s_set_flag(sc, TAIL_CONTEXT);
3378                s_thread_to(sc,OP_BEGIN);
3379           } else if (is_continuation(sc->code)) { /* CONTINUATION */
3380                sc->dump = cont_dump(sc->code);
3381                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
3382           } else {
3383                Error_1(sc,"illegal function",sc->code);
3384           }
3385
3386      CASE(OP_DOMACRO):    /* do macro */
3387           sc->code = sc->value;
3388           s_thread_to(sc,OP_EVAL);
3389
3390 #if USE_COMPILE_HOOK
3391      CASE(OP_LAMBDA):     /* lambda */
3392           /* If the hook is defined, apply it to sc->code, otherwise
3393              set sc->value fall through */
3394           {
3395                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
3396                if(f==sc->NIL) {
3397                     sc->value = sc->code;
3398                     /* Fallthru */
3399                } else {
3400                     gc_disable(sc, 1 + gc_reservations (s_save));
3401                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
3402                     sc->args=cons(sc,sc->code,sc->NIL);
3403                     gc_enable(sc);
3404                     sc->code=slot_value_in_env(f);
3405                     s_thread_to(sc,OP_APPLY);
3406                }
3407           }
3408
3409 #else
3410      CASE(OP_LAMBDA):     /* lambda */
3411           sc->value = sc->code;
3412           /* Fallthrough. */
3413 #endif
3414
3415      CASE(OP_LAMBDA1):
3416           gc_disable(sc, 1);
3417           s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
3418
3419
3420      CASE(OP_MKCLOSURE): /* make-closure */
3421        x=car(sc->args);
3422        if(car(x)==sc->LAMBDA) {
3423          x=cdr(x);
3424        }
3425        if(cdr(sc->args)==sc->NIL) {
3426          y=sc->envir;
3427        } else {
3428          y=cadr(sc->args);
3429        }
3430        gc_disable(sc, 1);
3431        s_return_enable_gc(sc, mk_closure(sc, x, y));
3432
3433      CASE(OP_QUOTE):      /* quote */
3434           s_return(sc,car(sc->code));
3435
3436      CASE(OP_DEF0):  /* define */
3437           if(is_immutable(car(sc->code)))
3438             Error_1(sc,"define: unable to alter immutable", car(sc->code));
3439
3440           if (is_pair(car(sc->code))) {
3441                x = caar(sc->code);
3442                gc_disable(sc, 2);
3443                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3444                gc_enable(sc);
3445           } else {
3446                x = car(sc->code);
3447                sc->code = cadr(sc->code);
3448           }
3449           if (!is_symbol(x)) {
3450                Error_0(sc,"variable is not a symbol");
3451           }
3452           s_save(sc,OP_DEF1, sc->NIL, x);
3453           s_thread_to(sc,OP_EVAL);
3454
3455      CASE(OP_DEF1):  /* define */
3456           x=find_slot_in_env(sc,sc->envir,sc->code,0);
3457           if (x != sc->NIL) {
3458                set_slot_in_env(sc, x, sc->value);
3459           } else {
3460                new_slot_in_env(sc, sc->code, sc->value);
3461           }
3462           s_return(sc,sc->code);
3463
3464
3465      CASE(OP_DEFP):  /* defined? */
3466           x=sc->envir;
3467           if(cdr(sc->args)!=sc->NIL) {
3468                x=cadr(sc->args);
3469           }
3470           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3471
3472      CASE(OP_SET0):       /* set! */
3473           if(is_immutable(car(sc->code)))
3474                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3475           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3476           sc->code = cadr(sc->code);
3477           s_thread_to(sc,OP_EVAL);
3478
3479      CASE(OP_SET1):       /* set! */
3480           y=find_slot_in_env(sc,sc->envir,sc->code,1);
3481           if (y != sc->NIL) {
3482                set_slot_in_env(sc, y, sc->value);
3483                s_return(sc,sc->value);
3484           } else {
3485                Error_1(sc,"set!: unbound variable:", sc->code);
3486           }
3487
3488
3489      CASE(OP_BEGIN):      /* begin */
3490           {
3491             int last;
3492
3493             if (!is_pair(sc->code)) {
3494               s_return(sc,sc->code);
3495             }
3496
3497             last = cdr(sc->code) == sc->NIL;
3498             if (!last) {
3499               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3500             }
3501             sc->code = car(sc->code);
3502             if (! last)
3503               /* This is not the end of the list.  This is not a tail
3504                * position.  */
3505               s_clear_flag(sc, TAIL_CONTEXT);
3506             s_thread_to(sc,OP_EVAL);
3507           }
3508
3509      CASE(OP_IF0):        /* if */
3510           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3511           sc->code = car(sc->code);
3512           s_clear_flag(sc, TAIL_CONTEXT);
3513           s_thread_to(sc,OP_EVAL);
3514
3515      CASE(OP_IF1):        /* if */
3516           if (is_true(sc->value))
3517                sc->code = car(sc->code);
3518           else
3519                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
3520                                             * car(sc->NIL) = sc->NIL */
3521           s_thread_to(sc,OP_EVAL);
3522
3523      CASE(OP_LET0):       /* let */
3524           sc->args = sc->NIL;
3525           sc->value = sc->code;
3526           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3527           s_thread_to(sc,OP_LET1);
3528
3529      CASE(OP_LET1):       /* let (calculate parameters) */
3530           gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3531           sc->args = cons(sc, sc->value, sc->args);
3532           if (is_pair(sc->code)) { /* continue */
3533                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3534                     gc_enable(sc);
3535                     Error_1(sc, "Bad syntax of binding spec in let :",
3536                             car(sc->code));
3537                }
3538                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
3539                gc_enable(sc);
3540                sc->code = cadar(sc->code);
3541                sc->args = sc->NIL;
3542                s_clear_flag(sc, TAIL_CONTEXT);
3543                s_thread_to(sc,OP_EVAL);
3544           } else {  /* end */
3545                gc_enable(sc);
3546                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3547                sc->code = car(sc->args);
3548                sc->args = cdr(sc->args);
3549                s_thread_to(sc,OP_LET2);
3550           }
3551
3552      CASE(OP_LET2):       /* let */
3553           new_frame_in_env(sc, sc->envir);
3554           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
3555                y != sc->NIL; x = cdr(x), y = cdr(y)) {
3556                new_slot_in_env(sc, caar(x), car(y));
3557           }
3558           if (is_symbol(car(sc->code))) {    /* named let */
3559                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
3560                     if (!is_pair(x))
3561                         Error_1(sc, "Bad syntax of binding in let :", x);
3562                     if (!is_list(sc, car(x)))
3563                         Error_1(sc, "Bad syntax of binding in let :", car(x));
3564                     gc_disable(sc, 1);
3565                     sc->args = cons(sc, caar(x), sc->args);
3566                     gc_enable(sc);
3567                }
3568                gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
3569                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
3570                new_slot_in_env(sc, car(sc->code), x);
3571                gc_enable(sc);
3572                sc->code = cddr(sc->code);
3573                sc->args = sc->NIL;
3574           } else {
3575                sc->code = cdr(sc->code);
3576                sc->args = sc->NIL;
3577           }
3578           s_thread_to(sc,OP_BEGIN);
3579
3580      CASE(OP_LET0AST):    /* let* */
3581           if (car(sc->code) == sc->NIL) {
3582                new_frame_in_env(sc, sc->envir);
3583                sc->code = cdr(sc->code);
3584                s_thread_to(sc,OP_BEGIN);
3585           }
3586           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
3587                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
3588           }
3589           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
3590           sc->code = cadaar(sc->code);
3591           s_clear_flag(sc, TAIL_CONTEXT);
3592           s_thread_to(sc,OP_EVAL);
3593
3594      CASE(OP_LET1AST):    /* let* (make new frame) */
3595           new_frame_in_env(sc, sc->envir);
3596           s_thread_to(sc,OP_LET2AST);
3597
3598      CASE(OP_LET2AST):    /* let* (calculate parameters) */
3599           new_slot_in_env(sc, caar(sc->code), sc->value);
3600           sc->code = cdr(sc->code);
3601           if (is_pair(sc->code)) { /* continue */
3602                s_save(sc,OP_LET2AST, sc->args, sc->code);
3603                sc->code = cadar(sc->code);
3604                sc->args = sc->NIL;
3605                s_clear_flag(sc, TAIL_CONTEXT);
3606                s_thread_to(sc,OP_EVAL);
3607           } else {  /* end */
3608                sc->code = sc->args;
3609                sc->args = sc->NIL;
3610                s_thread_to(sc,OP_BEGIN);
3611           }
3612      default:
3613           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3614           Error_0(sc,sc->strbuff);
3615      }
3616      return sc->T;
3617 }
3618
3619 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
3620      pointer x, y;
3621
3622      switch (op) {
3623      CASE(OP_LET0REC):    /* letrec */
3624           new_frame_in_env(sc, sc->envir);
3625           sc->args = sc->NIL;
3626           sc->value = sc->code;
3627           sc->code = car(sc->code);
3628           s_thread_to(sc,OP_LET1REC);
3629
3630      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
3631           gc_disable(sc, 1);
3632           sc->args = cons(sc, sc->value, sc->args);
3633           gc_enable(sc);
3634           if (is_pair(sc->code)) { /* continue */
3635                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3636                     Error_1(sc, "Bad syntax of binding spec in letrec :",
3637                             car(sc->code));
3638                }
3639                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
3640                sc->code = cadar(sc->code);
3641                sc->args = sc->NIL;
3642                s_clear_flag(sc, TAIL_CONTEXT);
3643                s_goto(sc,OP_EVAL);
3644           } else {  /* end */
3645                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3646                sc->code = car(sc->args);
3647                sc->args = cdr(sc->args);
3648                s_thread_to(sc,OP_LET2REC);
3649           }
3650
3651      CASE(OP_LET2REC):    /* letrec */
3652           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
3653                new_slot_in_env(sc, caar(x), car(y));
3654           }
3655           sc->code = cdr(sc->code);
3656           sc->args = sc->NIL;
3657           s_goto(sc,OP_BEGIN);
3658
3659      CASE(OP_COND0):      /* cond */
3660           if (!is_pair(sc->code)) {
3661                Error_0(sc,"syntax error in cond");
3662           }
3663           s_save(sc,OP_COND1, sc->NIL, sc->code);
3664           sc->code = caar(sc->code);
3665           s_clear_flag(sc, TAIL_CONTEXT);
3666           s_goto(sc,OP_EVAL);
3667
3668      CASE(OP_COND1):      /* cond */
3669           if (is_true(sc->value)) {
3670                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3671                     s_return(sc,sc->value);
3672                }
3673                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3674                     if(!is_pair(cdr(sc->code))) {
3675                          Error_0(sc,"syntax error in cond");
3676                     }
3677                     gc_disable(sc, 4);
3678                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3679                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3680                     gc_enable(sc);
3681                     s_goto(sc,OP_EVAL);
3682                }
3683                s_goto(sc,OP_BEGIN);
3684           } else {
3685                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3686                     s_return(sc,sc->NIL);
3687                } else {
3688                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3689                     sc->code = caar(sc->code);
3690                     s_clear_flag(sc, TAIL_CONTEXT);
3691                     s_goto(sc,OP_EVAL);
3692                }
3693           }
3694
3695      CASE(OP_DELAY):      /* delay */
3696           gc_disable(sc, 2);
3697           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3698           typeflag(x)=T_PROMISE;
3699           s_return_enable_gc(sc,x);
3700
3701      CASE(OP_AND0):       /* and */
3702           if (sc->code == sc->NIL) {
3703                s_return(sc,sc->T);
3704           }
3705           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3706           if (cdr(sc->code) != sc->NIL)
3707                s_clear_flag(sc, TAIL_CONTEXT);
3708           sc->code = car(sc->code);
3709           s_goto(sc,OP_EVAL);
3710
3711      CASE(OP_AND1):       /* and */
3712           if (is_false(sc->value)) {
3713                s_return(sc,sc->value);
3714           } else if (sc->code == sc->NIL) {
3715                s_return(sc,sc->value);
3716           } else {
3717                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3718                if (cdr(sc->code) != sc->NIL)
3719                     s_clear_flag(sc, TAIL_CONTEXT);
3720                sc->code = car(sc->code);
3721                s_goto(sc,OP_EVAL);
3722           }
3723
3724      CASE(OP_OR0):        /* or */
3725           if (sc->code == sc->NIL) {
3726                s_return(sc,sc->F);
3727           }
3728           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3729           if (cdr(sc->code) != sc->NIL)
3730                s_clear_flag(sc, TAIL_CONTEXT);
3731           sc->code = car(sc->code);
3732           s_goto(sc,OP_EVAL);
3733
3734      CASE(OP_OR1):        /* or */
3735           if (is_true(sc->value)) {
3736                s_return(sc,sc->value);
3737           } else if (sc->code == sc->NIL) {
3738                s_return(sc,sc->value);
3739           } else {
3740                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3741                if (cdr(sc->code) != sc->NIL)
3742                     s_clear_flag(sc, TAIL_CONTEXT);
3743                sc->code = car(sc->code);
3744                s_goto(sc,OP_EVAL);
3745           }
3746
3747      CASE(OP_C0STREAM):   /* cons-stream */
3748           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3749           sc->code = car(sc->code);
3750           s_goto(sc,OP_EVAL);
3751
3752      CASE(OP_C1STREAM):   /* cons-stream */
3753           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3754           gc_disable(sc, 3);
3755           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3756           typeflag(x)=T_PROMISE;
3757           s_return_enable_gc(sc, cons(sc, sc->args, x));
3758
3759      CASE(OP_MACRO0):     /* macro */
3760           if (is_pair(car(sc->code))) {
3761                x = caar(sc->code);
3762                gc_disable(sc, 2);
3763                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3764                gc_enable(sc);
3765           } else {
3766                x = car(sc->code);
3767                sc->code = cadr(sc->code);
3768           }
3769           if (!is_symbol(x)) {
3770                Error_0(sc,"variable is not a symbol");
3771           }
3772           s_save(sc,OP_MACRO1, sc->NIL, x);
3773           s_goto(sc,OP_EVAL);
3774
3775      CASE(OP_MACRO1):     /* macro */
3776           typeflag(sc->value) = T_MACRO;
3777           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3778           if (x != sc->NIL) {
3779                set_slot_in_env(sc, x, sc->value);
3780           } else {
3781                new_slot_in_env(sc, sc->code, sc->value);
3782           }
3783           s_return(sc,sc->code);
3784
3785      CASE(OP_CASE0):      /* case */
3786           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3787           sc->code = car(sc->code);
3788           s_clear_flag(sc, TAIL_CONTEXT);
3789           s_goto(sc,OP_EVAL);
3790
3791      CASE(OP_CASE1):      /* case */
3792           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3793                if (!is_pair(y = caar(x))) {
3794                     break;
3795                }
3796                for ( ; y != sc->NIL; y = cdr(y)) {
3797                     if (eqv(car(y), sc->value)) {
3798                          break;
3799                     }
3800                }
3801                if (y != sc->NIL) {
3802                     break;
3803                }
3804           }
3805           if (x != sc->NIL) {
3806                if (is_pair(caar(x))) {
3807                     sc->code = cdar(x);
3808                     s_goto(sc,OP_BEGIN);
3809                } else {/* else */
3810                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3811                     sc->code = caar(x);
3812                     s_goto(sc,OP_EVAL);
3813                }
3814           } else {
3815                s_return(sc,sc->NIL);
3816           }
3817
3818      CASE(OP_CASE2):      /* case */
3819           if (is_true(sc->value)) {
3820                s_goto(sc,OP_BEGIN);
3821           } else {
3822                s_return(sc,sc->NIL);
3823           }
3824
3825      CASE(OP_PAPPLY):     /* apply */
3826           sc->code = car(sc->args);
3827           sc->args = list_star(sc,cdr(sc->args));
3828           /*sc->args = cadr(sc->args);*/
3829           s_goto(sc,OP_APPLY);
3830
3831      CASE(OP_PEVAL): /* eval */
3832           if(cdr(sc->args)!=sc->NIL) {
3833                sc->envir=cadr(sc->args);
3834           }
3835           sc->code = car(sc->args);
3836           s_goto(sc,OP_EVAL);
3837
3838      CASE(OP_CONTINUATION):    /* call-with-current-continuation */
3839           sc->code = car(sc->args);
3840           gc_disable(sc, 2);
3841           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3842           gc_enable(sc);
3843           s_goto(sc,OP_APPLY);
3844
3845      default:
3846           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3847           Error_0(sc,sc->strbuff);
3848      }
3849      return sc->T;
3850 }
3851
3852 #if USE_PLIST
3853 static pointer
3854 get_property(scheme *sc, pointer obj, pointer key)
3855 {
3856   pointer x;
3857
3858   assert (is_symbol(obj));
3859   assert (is_symbol(key));
3860
3861   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3862     if (caar(x) == key)
3863       break;
3864   }
3865
3866   if (x != sc->NIL)
3867     return cdar(x);
3868
3869   return sc->NIL;
3870 }
3871
3872 static pointer
3873 set_property(scheme *sc, pointer obj, pointer key, pointer value)
3874 {
3875 #define set_property_allocates  2
3876   pointer x;
3877
3878   assert (is_symbol(obj));
3879   assert (is_symbol(key));
3880
3881   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3882     if (caar(x) == key)
3883       break;
3884   }
3885
3886   if (x != sc->NIL)
3887     cdar(x) = value;
3888   else {
3889     gc_disable(sc, gc_reservations(set_property));
3890     symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
3891     gc_enable(sc);
3892   }
3893
3894   return sc->T;
3895 }
3896 #endif
3897
3898 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3899      pointer x;
3900      num v;
3901 #if USE_MATH
3902      double dd;
3903 #endif
3904
3905      switch (op) {
3906 #if USE_MATH
3907      CASE(OP_INEX2EX):    /* inexact->exact */
3908           x=car(sc->args);
3909           if(num_is_integer(x)) {
3910                s_return(sc,x);
3911           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3912                s_return(sc,mk_integer(sc,ivalue(x)));
3913           } else {
3914                Error_1(sc,"inexact->exact: not integral:",x);
3915           }
3916
3917      CASE(OP_EXP):
3918           x=car(sc->args);
3919           s_return(sc, mk_real(sc, exp(rvalue(x))));
3920
3921      CASE(OP_LOG):
3922           x=car(sc->args);
3923           s_return(sc, mk_real(sc, log(rvalue(x))));
3924
3925      CASE(OP_SIN):
3926           x=car(sc->args);
3927           s_return(sc, mk_real(sc, sin(rvalue(x))));
3928
3929      CASE(OP_COS):
3930           x=car(sc->args);
3931           s_return(sc, mk_real(sc, cos(rvalue(x))));
3932
3933      CASE(OP_TAN):
3934           x=car(sc->args);
3935           s_return(sc, mk_real(sc, tan(rvalue(x))));
3936
3937      CASE(OP_ASIN):
3938           x=car(sc->args);
3939           s_return(sc, mk_real(sc, asin(rvalue(x))));
3940
3941      CASE(OP_ACOS):
3942           x=car(sc->args);
3943           s_return(sc, mk_real(sc, acos(rvalue(x))));
3944
3945      CASE(OP_ATAN):
3946           x=car(sc->args);
3947           if(cdr(sc->args)==sc->NIL) {
3948                s_return(sc, mk_real(sc, atan(rvalue(x))));
3949           } else {
3950                pointer y=cadr(sc->args);
3951                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3952           }
3953
3954      CASE(OP_SQRT):
3955           x=car(sc->args);
3956           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3957
3958      CASE(OP_EXPT): {
3959           double result;
3960           int real_result=1;
3961           pointer y=cadr(sc->args);
3962           x=car(sc->args);
3963           if (num_is_integer(x) && num_is_integer(y))
3964              real_result=0;
3965           /* This 'if' is an R5RS compatibility fix. */
3966           /* NOTE: Remove this 'if' fix for R6RS.    */
3967           if (rvalue(x) == 0 && rvalue(y) < 0) {
3968              result = 0.0;
3969           } else {
3970              result = pow(rvalue(x),rvalue(y));
3971           }
3972           /* Before returning integer result make sure we can. */
3973           /* If the test fails, result is too big for integer. */
3974           if (!real_result)
3975           {
3976             long result_as_long = (long)result;
3977             if (result != (double)result_as_long)
3978               real_result = 1;
3979           }
3980           if (real_result) {
3981              s_return(sc, mk_real(sc, result));
3982           } else {
3983              s_return(sc, mk_integer(sc, result));
3984           }
3985      }
3986
3987      CASE(OP_FLOOR):
3988           x=car(sc->args);
3989           s_return(sc, mk_real(sc, floor(rvalue(x))));
3990
3991      CASE(OP_CEILING):
3992           x=car(sc->args);
3993           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3994
3995      CASE(OP_TRUNCATE ): {
3996           double rvalue_of_x ;
3997           x=car(sc->args);
3998           rvalue_of_x = rvalue(x) ;
3999           if (rvalue_of_x > 0) {
4000             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
4001           } else {
4002             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
4003           }
4004      }
4005
4006      CASE(OP_ROUND):
4007         x=car(sc->args);
4008         if (num_is_integer(x))
4009             s_return(sc, x);
4010         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
4011 #endif
4012
4013      CASE(OP_ADD):        /* + */
4014        v=num_zero;
4015        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4016          v=num_add(v,nvalue(car(x)));
4017        }
4018        gc_disable(sc, 1);
4019        s_return_enable_gc(sc, mk_number(sc, v));
4020
4021      CASE(OP_MUL):        /* * */
4022        v=num_one;
4023        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4024          v=num_mul(v,nvalue(car(x)));
4025        }
4026        gc_disable(sc, 1);
4027        s_return_enable_gc(sc, mk_number(sc, v));
4028
4029      CASE(OP_SUB):        /* - */
4030        if(cdr(sc->args)==sc->NIL) {
4031          x=sc->args;
4032          v=num_zero;
4033        } else {
4034          x = cdr(sc->args);
4035          v = nvalue(car(sc->args));
4036        }
4037        for (; x != sc->NIL; x = cdr(x)) {
4038          v=num_sub(v,nvalue(car(x)));
4039        }
4040        gc_disable(sc, 1);
4041        s_return_enable_gc(sc, mk_number(sc, v));
4042
4043      CASE(OP_DIV):        /* / */
4044        if(cdr(sc->args)==sc->NIL) {
4045          x=sc->args;
4046          v=num_one;
4047        } else {
4048          x = cdr(sc->args);
4049          v = nvalue(car(sc->args));
4050        }
4051        for (; x != sc->NIL; x = cdr(x)) {
4052          if (!is_zero_double(rvalue(car(x))))
4053            v=num_div(v,nvalue(car(x)));
4054          else {
4055            Error_0(sc,"/: division by zero");
4056          }
4057        }
4058        gc_disable(sc, 1);
4059        s_return_enable_gc(sc, mk_number(sc, v));
4060
4061      CASE(OP_INTDIV):        /* quotient */
4062           if(cdr(sc->args)==sc->NIL) {
4063                x=sc->args;
4064                v=num_one;
4065           } else {
4066                x = cdr(sc->args);
4067                v = nvalue(car(sc->args));
4068           }
4069           for (; x != sc->NIL; x = cdr(x)) {
4070                if (ivalue(car(x)) != 0)
4071                     v=num_intdiv(v,nvalue(car(x)));
4072                else {
4073                     Error_0(sc,"quotient: division by zero");
4074                }
4075           }
4076           gc_disable(sc, 1);
4077           s_return_enable_gc(sc, mk_number(sc, v));
4078
4079      CASE(OP_REM):        /* remainder */
4080           v = nvalue(car(sc->args));
4081           if (ivalue(cadr(sc->args)) != 0)
4082                v=num_rem(v,nvalue(cadr(sc->args)));
4083           else {
4084                Error_0(sc,"remainder: division by zero");
4085           }
4086           gc_disable(sc, 1);
4087           s_return_enable_gc(sc, mk_number(sc, v));
4088
4089      CASE(OP_MOD):        /* modulo */
4090           v = nvalue(car(sc->args));
4091           if (ivalue(cadr(sc->args)) != 0)
4092                v=num_mod(v,nvalue(cadr(sc->args)));
4093           else {
4094                Error_0(sc,"modulo: division by zero");
4095           }
4096           gc_disable(sc, 1);
4097           s_return_enable_gc(sc, mk_number(sc, v));
4098
4099      CASE(OP_CAR):        /* car */
4100           s_return(sc,caar(sc->args));
4101
4102      CASE(OP_CDR):        /* cdr */
4103           s_return(sc,cdar(sc->args));
4104
4105      CASE(OP_CONS):       /* cons */
4106           cdr(sc->args) = cadr(sc->args);
4107           s_return(sc,sc->args);
4108
4109      CASE(OP_SETCAR):     /* set-car! */
4110        if(!is_immutable(car(sc->args))) {
4111          caar(sc->args) = cadr(sc->args);
4112          s_return(sc,car(sc->args));
4113        } else {
4114          Error_0(sc,"set-car!: unable to alter immutable pair");
4115        }
4116
4117      CASE(OP_SETCDR):     /* set-cdr! */
4118        if(!is_immutable(car(sc->args))) {
4119          cdar(sc->args) = cadr(sc->args);
4120          s_return(sc,car(sc->args));
4121        } else {
4122          Error_0(sc,"set-cdr!: unable to alter immutable pair");
4123        }
4124
4125      CASE(OP_CHAR2INT): { /* char->integer */
4126           char c;
4127           c=(char)ivalue(car(sc->args));
4128           gc_disable(sc, 1);
4129           s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
4130      }
4131
4132      CASE(OP_INT2CHAR): { /* integer->char */
4133           unsigned char c;
4134           c=(unsigned char)ivalue(car(sc->args));
4135           gc_disable(sc, 1);
4136           s_return_enable_gc(sc, mk_character(sc, (char) c));
4137      }
4138
4139      CASE(OP_CHARUPCASE): {
4140           unsigned char c;
4141           c=(unsigned char)ivalue(car(sc->args));
4142           c=toupper(c);
4143           gc_disable(sc, 1);
4144           s_return_enable_gc(sc, mk_character(sc, (char) c));
4145      }
4146
4147      CASE(OP_CHARDNCASE): {
4148           unsigned char c;
4149           c=(unsigned char)ivalue(car(sc->args));
4150           c=tolower(c);
4151           gc_disable(sc, 1);
4152           s_return_enable_gc(sc, mk_character(sc, (char) c));
4153      }
4154
4155      CASE(OP_STR2SYM):  /* string->symbol */
4156           gc_disable(sc, gc_reservations (mk_symbol));
4157           s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
4158
4159      CASE(OP_STR2ATOM): /* string->atom */ {
4160           char *s=strvalue(car(sc->args));
4161           long pf = 0;
4162           if(cdr(sc->args)!=sc->NIL) {
4163             /* we know cadr(sc->args) is a natural number */
4164             /* see if it is 2, 8, 10, or 16, or error */
4165             pf = ivalue_unchecked(cadr(sc->args));
4166             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
4167                /* base is OK */
4168             }
4169             else {
4170               pf = -1;
4171             }
4172           }
4173           if (pf < 0) {
4174             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
4175           } else if(*s=='#') /* no use of base! */ {
4176             s_return(sc, mk_sharp_const(sc, s+1));
4177           } else {
4178             if (pf == 0 || pf == 10) {
4179               s_return(sc, mk_atom(sc, s));
4180             }
4181             else {
4182               char *ep;
4183               long iv = strtol(s,&ep,(int )pf);
4184               if (*ep == 0) {
4185                 s_return(sc, mk_integer(sc, iv));
4186               }
4187               else {
4188                 s_return(sc, sc->F);
4189               }
4190             }
4191           }
4192         }
4193
4194      CASE(OP_SYM2STR): /* symbol->string */
4195           gc_disable(sc, 1);
4196           x=mk_string(sc,symname(car(sc->args)));
4197           setimmutable(x);
4198           s_return_enable_gc(sc, x);
4199
4200      CASE(OP_ATOM2STR): /* atom->string */ {
4201           long pf = 0;
4202           x=car(sc->args);
4203           if(cdr(sc->args)!=sc->NIL) {
4204             /* we know cadr(sc->args) is a natural number */
4205             /* see if it is 2, 8, 10, or 16, or error */
4206             pf = ivalue_unchecked(cadr(sc->args));
4207             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
4208               /* base is OK */
4209             }
4210             else {
4211               pf = -1;
4212             }
4213           }
4214           if (pf < 0) {
4215             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
4216           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
4217             char *p;
4218             int len;
4219             atom2str(sc,x,(int )pf,&p,&len);
4220             gc_disable(sc, 1);
4221             s_return_enable_gc(sc, mk_counted_string(sc, p, len));
4222           } else {
4223             Error_1(sc, "atom->string: not an atom:", x);
4224           }
4225         }
4226
4227      CASE(OP_MKSTRING): { /* make-string */
4228           int fill=' ';
4229           int len;
4230
4231           len=ivalue(car(sc->args));
4232
4233           if(cdr(sc->args)!=sc->NIL) {
4234                fill=charvalue(cadr(sc->args));
4235           }
4236           gc_disable(sc, 1);
4237           s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
4238      }
4239
4240      CASE(OP_STRLEN):  /* string-length */
4241           gc_disable(sc, 1);
4242           s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
4243
4244      CASE(OP_STRREF): { /* string-ref */
4245           char *str;
4246           int index;
4247
4248           str=strvalue(car(sc->args));
4249
4250           index=ivalue(cadr(sc->args));
4251
4252           if(index>=strlength(car(sc->args))) {
4253                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
4254           }
4255
4256           gc_disable(sc, 1);
4257           s_return_enable_gc(sc,
4258                              mk_character(sc, ((unsigned char*) str)[index]));
4259      }
4260
4261      CASE(OP_STRSET): { /* string-set! */
4262           char *str;
4263           int index;
4264           int c;
4265
4266           if(is_immutable(car(sc->args))) {
4267                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
4268           }
4269           str=strvalue(car(sc->args));
4270
4271           index=ivalue(cadr(sc->args));
4272           if(index>=strlength(car(sc->args))) {
4273                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
4274           }
4275
4276           c=charvalue(caddr(sc->args));
4277
4278           str[index]=(char)c;
4279           s_return(sc,car(sc->args));
4280      }
4281
4282      CASE(OP_STRAPPEND): { /* string-append */
4283        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4284        int len = 0;
4285        pointer newstr;
4286        char *pos;
4287
4288        /* compute needed length for new string */
4289        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4290           len += strlength(car(x));
4291        }
4292        gc_disable(sc, 1);
4293        newstr = mk_empty_string(sc, len, ' ');
4294        /* store the contents of the argument strings into the new string */
4295        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
4296            pos += strlength(car(x)), x = cdr(x)) {
4297            memcpy(pos, strvalue(car(x)), strlength(car(x)));
4298        }
4299        s_return_enable_gc(sc, newstr);
4300      }
4301
4302      CASE(OP_SUBSTR): { /* substring */
4303           char *str;
4304           int index0;
4305           int index1;
4306           int len;
4307
4308           str=strvalue(car(sc->args));
4309
4310           index0=ivalue(cadr(sc->args));
4311
4312           if(index0>strlength(car(sc->args))) {
4313                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
4314           }
4315
4316           if(cddr(sc->args)!=sc->NIL) {
4317                index1=ivalue(caddr(sc->args));
4318                if(index1>strlength(car(sc->args)) || index1<index0) {
4319                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
4320                }
4321           } else {
4322                index1=strlength(car(sc->args));
4323           }
4324
4325           len=index1-index0;
4326           gc_disable(sc, 1);
4327           x=mk_empty_string(sc,len,' ');
4328           memcpy(strvalue(x),str+index0,len);
4329           strvalue(x)[len]=0;
4330
4331           s_return_enable_gc(sc, x);
4332      }
4333
4334      CASE(OP_VECTOR): {   /* vector */
4335           int i;
4336           pointer vec;
4337           int len=list_length(sc,sc->args);
4338           if(len<0) {
4339                Error_1(sc,"vector: not a proper list:",sc->args);
4340           }
4341           vec=mk_vector(sc,len);
4342           if(sc->no_memory) { s_return(sc, sc->sink); }
4343           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
4344                set_vector_elem(vec,i,car(x));
4345           }
4346           s_return(sc,vec);
4347      }
4348
4349      CASE(OP_MKVECTOR): { /* make-vector */
4350           pointer fill=sc->NIL;
4351           int len;
4352           pointer vec;
4353
4354           len=ivalue(car(sc->args));
4355
4356           if(cdr(sc->args)!=sc->NIL) {
4357                fill=cadr(sc->args);
4358           }
4359           vec=mk_vector(sc,len);
4360           if(sc->no_memory) { s_return(sc, sc->sink); }
4361           if(fill!=sc->NIL) {
4362                fill_vector(vec,fill);
4363           }
4364           s_return(sc,vec);
4365      }
4366
4367      CASE(OP_VECLEN):  /* vector-length */
4368           gc_disable(sc, 1);
4369           s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
4370
4371      CASE(OP_VECREF): { /* vector-ref */
4372           int index;
4373
4374           index=ivalue(cadr(sc->args));
4375
4376           if(index>=ivalue(car(sc->args))) {
4377                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
4378           }
4379
4380           s_return(sc,vector_elem(car(sc->args),index));
4381      }
4382
4383      CASE(OP_VECSET): {   /* vector-set! */
4384           int index;
4385
4386           if(is_immutable(car(sc->args))) {
4387                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
4388           }
4389
4390           index=ivalue(cadr(sc->args));
4391           if(index>=ivalue(car(sc->args))) {
4392                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
4393           }
4394
4395           set_vector_elem(car(sc->args),index,caddr(sc->args));
4396           s_return(sc,car(sc->args));
4397      }
4398
4399      default:
4400           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4401           Error_0(sc,sc->strbuff);
4402      }
4403      return sc->T;
4404 }
4405
4406 static int is_list(scheme *sc, pointer a)
4407 { return list_length(sc,a) >= 0; }
4408
4409 /* Result is:
4410    proper list: length
4411    circular list: -1
4412    not even a pair: -2
4413    dotted list: -2 minus length before dot
4414 */
4415 int list_length(scheme *sc, pointer a) {
4416     int i=0;
4417     pointer slow, fast;
4418
4419     slow = fast = a;
4420     while (1)
4421     {
4422         if (fast == sc->NIL)
4423                 return i;
4424         if (!is_pair(fast))
4425                 return -2 - i;
4426         fast = cdr(fast);
4427         ++i;
4428         if (fast == sc->NIL)
4429                 return i;
4430         if (!is_pair(fast))
4431                 return -2 - i;
4432         ++i;
4433         fast = cdr(fast);
4434
4435         /* Safe because we would have already returned if `fast'
4436            encountered a non-pair. */
4437         slow = cdr(slow);
4438         if (fast == slow)
4439         {
4440             /* the fast pointer has looped back around and caught up
4441                with the slow pointer, hence the structure is circular,
4442                not of finite length, and therefore not a list */
4443             return -1;
4444         }
4445     }
4446 }
4447
4448 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
4449      pointer x;
4450      num v;
4451      int (*comp_func)(num,num)=0;
4452
4453      switch (op) {
4454      CASE(OP_NOT):        /* not */
4455           s_retbool(is_false(car(sc->args)));
4456      CASE(OP_BOOLP):       /* boolean? */
4457           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
4458      CASE(OP_EOFOBJP):       /* boolean? */
4459           s_retbool(car(sc->args) == sc->EOF_OBJ);
4460      CASE(OP_NULLP):       /* null? */
4461           s_retbool(car(sc->args) == sc->NIL);
4462      CASE(OP_NUMEQ):      /* = */
4463      CASE(OP_LESS):       /* < */
4464      CASE(OP_GRE):        /* > */
4465      CASE(OP_LEQ):        /* <= */
4466      CASE(OP_GEQ):        /* >= */
4467           switch(op) {
4468                case OP_NUMEQ: comp_func=num_eq; break;
4469                case OP_LESS:  comp_func=num_lt; break;
4470                case OP_GRE:   comp_func=num_gt; break;
4471                case OP_LEQ:   comp_func=num_le; break;
4472                case OP_GEQ:   comp_func=num_ge; break;
4473                default: assert (! "reached");
4474           }
4475           x=sc->args;
4476           v=nvalue(car(x));
4477           x=cdr(x);
4478
4479           for (; x != sc->NIL; x = cdr(x)) {
4480                if(!comp_func(v,nvalue(car(x)))) {
4481                     s_retbool(0);
4482                }
4483            v=nvalue(car(x));
4484           }
4485           s_retbool(1);
4486      CASE(OP_SYMBOLP):     /* symbol? */
4487           s_retbool(is_symbol(car(sc->args)));
4488      CASE(OP_NUMBERP):     /* number? */
4489           s_retbool(is_number(car(sc->args)));
4490      CASE(OP_STRINGP):     /* string? */
4491           s_retbool(is_string(car(sc->args)));
4492      CASE(OP_INTEGERP):     /* integer? */
4493           s_retbool(is_integer(car(sc->args)));
4494      CASE(OP_REALP):     /* real? */
4495           s_retbool(is_number(car(sc->args))); /* All numbers are real */
4496      CASE(OP_CHARP):     /* char? */
4497           s_retbool(is_character(car(sc->args)));
4498 #if USE_CHAR_CLASSIFIERS
4499      CASE(OP_CHARAP):     /* char-alphabetic? */
4500           s_retbool(Cisalpha(ivalue(car(sc->args))));
4501      CASE(OP_CHARNP):     /* char-numeric? */
4502           s_retbool(Cisdigit(ivalue(car(sc->args))));
4503      CASE(OP_CHARWP):     /* char-whitespace? */
4504           s_retbool(Cisspace(ivalue(car(sc->args))));
4505      CASE(OP_CHARUP):     /* char-upper-case? */
4506           s_retbool(Cisupper(ivalue(car(sc->args))));
4507      CASE(OP_CHARLP):     /* char-lower-case? */
4508           s_retbool(Cislower(ivalue(car(sc->args))));
4509 #endif
4510      CASE(OP_PORTP):     /* port? */
4511           s_retbool(is_port(car(sc->args)));
4512      CASE(OP_INPORTP):     /* input-port? */
4513           s_retbool(is_inport(car(sc->args)));
4514      CASE(OP_OUTPORTP):     /* output-port? */
4515           s_retbool(is_outport(car(sc->args)));
4516      CASE(OP_PROCP):       /* procedure? */
4517           /*--
4518               * continuation should be procedure by the example
4519               * (call-with-current-continuation procedure?) ==> #t
4520                  * in R^3 report sec. 6.9
4521               */
4522           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
4523                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
4524      CASE(OP_PAIRP):       /* pair? */
4525           s_retbool(is_pair(car(sc->args)));
4526      CASE(OP_LISTP):       /* list? */
4527        s_retbool(list_length(sc,car(sc->args)) >= 0);
4528
4529      CASE(OP_ENVP):        /* environment? */
4530           s_retbool(is_environment(car(sc->args)));
4531      CASE(OP_VECTORP):     /* vector? */
4532           s_retbool(is_vector(car(sc->args)));
4533      CASE(OP_EQ):         /* eq? */
4534           s_retbool(car(sc->args) == cadr(sc->args));
4535      CASE(OP_EQV):        /* eqv? */
4536           s_retbool(eqv(car(sc->args), cadr(sc->args)));
4537      default:
4538           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4539           Error_0(sc,sc->strbuff);
4540      }
4541      return sc->T;
4542 }
4543
4544 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
4545      pointer x, y;
4546
4547      switch (op) {
4548      CASE(OP_FORCE):      /* force */
4549           sc->code = car(sc->args);
4550           if (is_promise(sc->code)) {
4551                /* Should change type to closure here */
4552                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
4553                sc->args = sc->NIL;
4554                s_goto(sc,OP_APPLY);
4555           } else {
4556                s_return(sc,sc->code);
4557           }
4558
4559      CASE(OP_SAVE_FORCED):     /* Save forced value replacing promise */
4560           memcpy(sc->code,sc->value,sizeof(struct cell));
4561           s_return(sc,sc->value);
4562
4563      CASE(OP_WRITE):      /* write */
4564      CASE(OP_DISPLAY):    /* display */
4565      CASE(OP_WRITE_CHAR): /* write-char */
4566           if(is_pair(cdr(sc->args))) {
4567                if(cadr(sc->args)!=sc->outport) {
4568                     x=cons(sc,sc->outport,sc->NIL);
4569                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4570                     sc->outport=cadr(sc->args);
4571                }
4572           }
4573           sc->args = car(sc->args);
4574           if(op==OP_WRITE) {
4575                sc->print_flag = 1;
4576           } else {
4577                sc->print_flag = 0;
4578           }
4579           s_goto(sc,OP_P0LIST);
4580
4581      CASE(OP_NEWLINE):    /* newline */
4582           if(is_pair(sc->args)) {
4583                if(car(sc->args)!=sc->outport) {
4584                     x=cons(sc,sc->outport,sc->NIL);
4585                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4586                     sc->outport=car(sc->args);
4587                }
4588           }
4589           putstr(sc, "\n");
4590           s_return(sc,sc->T);
4591
4592      CASE(OP_ERR0):  /* error */
4593           sc->retcode=-1;
4594           if (!is_string(car(sc->args))) {
4595                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
4596                setimmutable(car(sc->args));
4597           }
4598           putstr(sc, "Error: ");
4599           putstr(sc, strvalue(car(sc->args)));
4600           sc->args = cdr(sc->args);
4601           s_thread_to(sc,OP_ERR1);
4602
4603      CASE(OP_ERR1):  /* error */
4604           putstr(sc, " ");
4605           if (sc->args != sc->NIL) {
4606                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
4607                sc->args = car(sc->args);
4608                sc->print_flag = 1;
4609                s_goto(sc,OP_P0LIST);
4610           } else {
4611                putstr(sc, "\n");
4612                if(sc->interactive_repl) {
4613                     s_goto(sc,OP_T0LVL);
4614                } else {
4615                     return sc->NIL;
4616                }
4617           }
4618
4619      CASE(OP_REVERSE):   /* reverse */
4620           s_return(sc,reverse(sc, sc->NIL, car(sc->args)));
4621
4622      CASE(OP_LIST_STAR): /* list* */
4623           s_return(sc,list_star(sc,sc->args));
4624
4625      CASE(OP_APPEND):    /* append */
4626           x = sc->NIL;
4627           y = sc->args;
4628           if (y == x) {
4629               s_return(sc, x);
4630           }
4631
4632           /* cdr() in the while condition is not a typo. If car() */
4633           /* is used (append '() 'a) will return the wrong result.*/
4634           while (cdr(y) != sc->NIL) {
4635               x = revappend(sc, x, car(y));
4636               y = cdr(y);
4637               if (x == sc->F) {
4638                   Error_0(sc, "non-list argument to append");
4639               }
4640           }
4641
4642           s_return(sc, reverse_in_place(sc, car(y), x));
4643
4644 #if USE_PLIST
4645      CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
4646           gc_disable(sc, gc_reservations(set_property));
4647           s_return_enable_gc(sc,
4648                              set_property(sc, car(sc->args),
4649                                           cadr(sc->args), caddr(sc->args)));
4650
4651      CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
4652           s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
4653 #endif /* USE_PLIST */
4654
4655 #if USE_TAGS
4656      CASE(OP_TAG_VALUE): {      /* not exposed */
4657           /* This tags sc->value with car(sc->args).  Useful to tag
4658            * results of opcode evaluations.  */
4659           pointer a, b, c;
4660           free_cons(sc, sc->args, &a, &b);
4661           free_cons(sc, b, &b, &c);
4662           assert(c == sc->NIL);
4663           s_return(sc, mk_tagged_value(sc, sc->value, a, b));
4664         }
4665
4666      CASE(OP_MK_TAGGED):        /* make-tagged-value */
4667           if (is_vector(car(sc->args)))
4668                Error_0(sc, "cannot tag vector");
4669           s_return(sc, mk_tagged_value(sc, car(sc->args),
4670                                        car(cadr(sc->args)),
4671                                        cdr(cadr(sc->args))));
4672
4673      CASE(OP_GET_TAG):        /* get-tag */
4674           s_return(sc, get_tag(sc, car(sc->args)));
4675 #endif /* USE_TAGS */
4676
4677      CASE(OP_QUIT):       /* quit */
4678           if(is_pair(sc->args)) {
4679                sc->retcode=ivalue(car(sc->args));
4680           }
4681           return (sc->NIL);
4682
4683      CASE(OP_GC):         /* gc */
4684           gc(sc, sc->NIL, sc->NIL);
4685           s_return(sc,sc->T);
4686
4687      CASE(OP_GCVERB):          /* gc-verbose */
4688      {    int  was = sc->gc_verbose;
4689
4690           sc->gc_verbose = (car(sc->args) != sc->F);
4691           s_retbool(was);
4692      }
4693
4694      CASE(OP_NEWSEGMENT): /* new-segment */
4695           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
4696                Error_0(sc,"new-segment: argument must be a number");
4697           }
4698           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
4699           s_return(sc,sc->T);
4700
4701      CASE(OP_OBLIST): /* oblist */
4702           s_return(sc, oblist_all_symbols(sc));
4703
4704      CASE(OP_CURR_INPORT): /* current-input-port */
4705           s_return(sc,sc->inport);
4706
4707      CASE(OP_CURR_OUTPORT): /* current-output-port */
4708           s_return(sc,sc->outport);
4709
4710      CASE(OP_OPEN_INFILE): /* open-input-file */
4711      CASE(OP_OPEN_OUTFILE): /* open-output-file */
4712      CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
4713           int prop=0;
4714           pointer p;
4715           switch(op) {
4716                case OP_OPEN_INFILE:     prop=port_input; break;
4717                case OP_OPEN_OUTFILE:    prop=port_output; break;
4718                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
4719                default: assert (! "reached");
4720           }
4721           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
4722           if(p==sc->NIL) {
4723                s_return(sc,sc->F);
4724           }
4725           s_return(sc,p);
4726           break;
4727      default: assert (! "reached");
4728      }
4729
4730 #if USE_STRING_PORTS
4731      CASE(OP_OPEN_INSTRING): /* open-input-string */
4732      CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ {
4733           int prop=0;
4734           pointer p;
4735           switch(op) {
4736                case OP_OPEN_INSTRING:     prop=port_input; break;
4737                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
4738                default: assert (! "reached");
4739           }
4740           p=port_from_string(sc, strvalue(car(sc->args)),
4741                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
4742           if(p==sc->NIL) {
4743                s_return(sc,sc->F);
4744           }
4745           s_return(sc,p);
4746      }
4747      CASE(OP_OPEN_OUTSTRING): /* open-output-string */ {
4748           pointer p;
4749           if(car(sc->args)==sc->NIL) {
4750                p=port_from_scratch(sc);
4751                if(p==sc->NIL) {
4752                     s_return(sc,sc->F);
4753                }
4754           } else {
4755                p=port_from_string(sc, strvalue(car(sc->args)),
4756                       strvalue(car(sc->args))+strlength(car(sc->args)),
4757                           port_output);
4758                if(p==sc->NIL) {
4759                     s_return(sc,sc->F);
4760                }
4761           }
4762           s_return(sc,p);
4763      }
4764      CASE(OP_GET_OUTSTRING): /* get-output-string */ {
4765           port *p;
4766
4767           if ((p=car(sc->args)->_object._port)->kind&port_string) {
4768                off_t size;
4769                char *str;
4770
4771                size=p->rep.string.curr-p->rep.string.start+1;
4772                str=sc->malloc(size);
4773                if(str != NULL) {
4774                     pointer s;
4775
4776                     memcpy(str,p->rep.string.start,size-1);
4777                     str[size-1]='\0';
4778                     s=mk_string(sc,str);
4779                     sc->free(str);
4780                     s_return(sc,s);
4781                }
4782           }
4783           s_return(sc,sc->F);
4784      }
4785 #endif
4786
4787      CASE(OP_CLOSE_INPORT): /* close-input-port */
4788           port_close(sc,car(sc->args),port_input);
4789           s_return(sc,sc->T);
4790
4791      CASE(OP_CLOSE_OUTPORT): /* close-output-port */
4792           port_close(sc,car(sc->args),port_output);
4793           s_return(sc,sc->T);
4794
4795      CASE(OP_INT_ENV): /* interaction-environment */
4796           s_return(sc,sc->global_env);
4797
4798      CASE(OP_CURR_ENV): /* current-environment */
4799           s_return(sc,sc->envir);
4800
4801      }
4802      return sc->T;
4803 }
4804
4805 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
4806      pointer x;
4807
4808      if(sc->nesting!=0) {
4809           int n=sc->nesting;
4810           sc->nesting=0;
4811           sc->retcode=-1;
4812           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
4813      }
4814
4815      switch (op) {
4816      /* ========== reading part ========== */
4817      CASE(OP_READ):
4818           if(!is_pair(sc->args)) {
4819                s_goto(sc,OP_READ_INTERNAL);
4820           }
4821           if(!is_inport(car(sc->args))) {
4822                Error_1(sc,"read: not an input port:",car(sc->args));
4823           }
4824           if(car(sc->args)==sc->inport) {
4825                s_goto(sc,OP_READ_INTERNAL);
4826           }
4827           x=sc->inport;
4828           sc->inport=car(sc->args);
4829           x=cons(sc,x,sc->NIL);
4830           s_save(sc,OP_SET_INPORT, x, sc->NIL);
4831           s_goto(sc,OP_READ_INTERNAL);
4832
4833      CASE(OP_READ_CHAR): /* read-char */
4834      CASE(OP_PEEK_CHAR): /* peek-char */ {
4835           int c;
4836           if(is_pair(sc->args)) {
4837                if(car(sc->args)!=sc->inport) {
4838                     x=sc->inport;
4839                     x=cons(sc,x,sc->NIL);
4840                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
4841                     sc->inport=car(sc->args);
4842                }
4843           }
4844           c=inchar(sc);
4845           if(c==EOF) {
4846                s_return(sc,sc->EOF_OBJ);
4847           }
4848           if(sc->op==OP_PEEK_CHAR) {
4849                backchar(sc,c);
4850           }
4851           s_return(sc,mk_character(sc,c));
4852      }
4853
4854      CASE(OP_CHAR_READY): /* char-ready? */ {
4855           pointer p=sc->inport;
4856           int res;
4857           if(is_pair(sc->args)) {
4858                p=car(sc->args);
4859           }
4860           res=p->_object._port->kind&port_string;
4861           s_retbool(res);
4862      }
4863
4864      CASE(OP_SET_INPORT): /* set-input-port */
4865           sc->inport=car(sc->args);
4866           s_return(sc,sc->value);
4867
4868      CASE(OP_SET_OUTPORT): /* set-output-port */
4869           sc->outport=car(sc->args);
4870           s_return(sc,sc->value);
4871
4872      CASE(OP_RDSEXPR):
4873           switch (sc->tok) {
4874           case TOK_EOF:
4875                s_return(sc,sc->EOF_OBJ);
4876           /* NOTREACHED */
4877           case TOK_VEC:
4878                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
4879                /* fall through */
4880           case TOK_LPAREN:
4881                sc->tok = token(sc);
4882                if (sc->tok == TOK_RPAREN) {
4883                     s_return(sc,sc->NIL);
4884                } else if (sc->tok == TOK_DOT) {
4885                     Error_0(sc,"syntax error: illegal dot expression");
4886                } else {
4887                     sc->nesting_stack[sc->file_i]++;
4888 #if USE_TAGS && SHOW_ERROR_LINE
4889                     if (sc->load_stack[sc->file_i].kind & port_file) {
4890                       pointer filename =
4891                         sc->load_stack[sc->file_i].rep.stdio.filename;
4892                       pointer lineno =
4893                         sc->load_stack[sc->file_i].rep.stdio.curr_line;
4894
4895                       s_save(sc, OP_TAG_VALUE,
4896                              cons(sc, filename, cons(sc, lineno, sc->NIL)),
4897                              sc->NIL);
4898                     }
4899 #endif
4900                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
4901                     s_thread_to(sc,OP_RDSEXPR);
4902                }
4903           case TOK_QUOTE:
4904                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
4905                sc->tok = token(sc);
4906                s_thread_to(sc,OP_RDSEXPR);
4907           case TOK_BQUOTE:
4908                sc->tok = token(sc);
4909                if(sc->tok==TOK_VEC) {
4910                  s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
4911                  sc->tok=TOK_LPAREN;
4912                  s_thread_to(sc,OP_RDSEXPR);
4913                } else {
4914                  s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
4915                }
4916                s_thread_to(sc,OP_RDSEXPR);
4917           case TOK_COMMA:
4918                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
4919                sc->tok = token(sc);
4920                s_thread_to(sc,OP_RDSEXPR);
4921           case TOK_ATMARK:
4922                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
4923                sc->tok = token(sc);
4924                s_thread_to(sc,OP_RDSEXPR);
4925           case TOK_ATOM:
4926                s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
4927           case TOK_DQUOTE:
4928                x=readstrexp(sc);
4929                if(x==sc->F) {
4930                  Error_0(sc,"Error reading string");
4931                }
4932                setimmutable(x);
4933                s_return(sc,x);
4934           case TOK_SHARP: {
4935                pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
4936                if(f==sc->NIL) {
4937                     Error_0(sc,"undefined sharp expression");
4938                } else {
4939                     sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
4940                     s_goto(sc,OP_EVAL);
4941                }
4942           }
4943           case TOK_SHARP_CONST:
4944                if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
4945                     Error_0(sc,"undefined sharp expression");
4946                } else {
4947                     s_return(sc,x);
4948                }
4949           default:
4950                Error_0(sc,"syntax error: illegal token");
4951           }
4952           break;
4953
4954      CASE(OP_RDLIST): {
4955           gc_disable(sc, 1);
4956           sc->args = cons(sc, sc->value, sc->args);
4957           gc_enable(sc);
4958           sc->tok = token(sc);
4959           if (sc->tok == TOK_EOF)
4960                { s_return(sc,sc->EOF_OBJ); }
4961           else if (sc->tok == TOK_RPAREN) {
4962                int c = inchar(sc);
4963                if (c != '\n')
4964                  backchar(sc,c);
4965 #if SHOW_ERROR_LINE
4966                else if (sc->load_stack[sc->file_i].kind & port_file)
4967                   port_increment_current_line(sc,
4968                                               &sc->load_stack[sc->file_i], 1);
4969 #endif
4970                sc->nesting_stack[sc->file_i]--;
4971                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
4972           } else if (sc->tok == TOK_DOT) {
4973                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
4974                sc->tok = token(sc);
4975                s_thread_to(sc,OP_RDSEXPR);
4976           } else {
4977                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
4978                s_thread_to(sc,OP_RDSEXPR);
4979           }
4980      }
4981
4982      CASE(OP_RDDOT):
4983           if (token(sc) != TOK_RPAREN) {
4984                Error_0(sc,"syntax error: illegal dot expression");
4985           } else {
4986                sc->nesting_stack[sc->file_i]--;
4987                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
4988           }
4989
4990      CASE(OP_RDQUOTE):
4991           gc_disable(sc, 2);
4992           s_return_enable_gc(sc, cons(sc, sc->QUOTE,
4993                                       cons(sc, sc->value, sc->NIL)));
4994
4995      CASE(OP_RDQQUOTE):
4996           gc_disable(sc, 2);
4997           s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
4998                                       cons(sc, sc->value, sc->NIL)));
4999
5000      CASE(OP_RDQQUOTEVEC):
5001           gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
5002           s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
5003            cons(sc, mk_symbol(sc,"vector"),
5004                  cons(sc,cons(sc, sc->QQUOTE,
5005                   cons(sc,sc->value,sc->NIL)),
5006                   sc->NIL))));
5007
5008      CASE(OP_RDUNQUOTE):
5009           gc_disable(sc, 2);
5010           s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
5011                                       cons(sc, sc->value, sc->NIL)));
5012
5013      CASE(OP_RDUQTSP):
5014           gc_disable(sc, 2);
5015           s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
5016                                       cons(sc, sc->value, sc->NIL)));
5017
5018      CASE(OP_RDVEC):
5019           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
5020           s_goto(sc,OP_EVAL); Cannot be quoted*/
5021           /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
5022           s_return(sc,x); Cannot be part of pairs*/
5023           /*sc->code=mk_proc(sc,OP_VECTOR);
5024           sc->args=sc->value;
5025           s_goto(sc,OP_APPLY);*/
5026           sc->args=sc->value;
5027           s_goto(sc,OP_VECTOR);
5028
5029      /* ========== printing part ========== */
5030      CASE(OP_P0LIST):
5031           if(is_vector(sc->args)) {
5032                putstr(sc,"#(");
5033                sc->args=cons(sc,sc->args,mk_integer(sc,0));
5034                s_thread_to(sc,OP_PVECFROM);
5035           } else if(is_environment(sc->args)) {
5036                putstr(sc,"#<ENVIRONMENT>");
5037                s_return(sc,sc->T);
5038           } else if (!is_pair(sc->args)) {
5039                printatom(sc, sc->args, sc->print_flag);
5040                s_return(sc,sc->T);
5041           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
5042                putstr(sc, "'");
5043                sc->args = cadr(sc->args);
5044                s_thread_to(sc,OP_P0LIST);
5045           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
5046                putstr(sc, "`");
5047                sc->args = cadr(sc->args);
5048                s_thread_to(sc,OP_P0LIST);
5049           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
5050                putstr(sc, ",");
5051                sc->args = cadr(sc->args);
5052                s_thread_to(sc,OP_P0LIST);
5053           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
5054                putstr(sc, ",@");
5055                sc->args = cadr(sc->args);
5056                s_thread_to(sc,OP_P0LIST);
5057           } else {
5058                putstr(sc, "(");
5059                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5060                sc->args = car(sc->args);
5061                s_thread_to(sc,OP_P0LIST);
5062           }
5063
5064      CASE(OP_P1LIST):
5065           if (is_pair(sc->args)) {
5066             s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5067             putstr(sc, " ");
5068             sc->args = car(sc->args);
5069             s_thread_to(sc,OP_P0LIST);
5070           } else if(is_vector(sc->args)) {
5071             s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
5072             putstr(sc, " . ");
5073             s_thread_to(sc,OP_P0LIST);
5074           } else {
5075             if (sc->args != sc->NIL) {
5076               putstr(sc, " . ");
5077               printatom(sc, sc->args, sc->print_flag);
5078             }
5079             putstr(sc, ")");
5080             s_return(sc,sc->T);
5081           }
5082      CASE(OP_PVECFROM): {
5083           int i=ivalue_unchecked(cdr(sc->args));
5084           pointer vec=car(sc->args);
5085           int len=ivalue_unchecked(vec);
5086           if(i==len) {
5087                putstr(sc,")");
5088                s_return(sc,sc->T);
5089           } else {
5090                pointer elem=vector_elem(vec,i);
5091                ivalue_unchecked(cdr(sc->args))=i+1;
5092                s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
5093                sc->args=elem;
5094                if (i > 0)
5095                    putstr(sc," ");
5096                s_thread_to(sc,OP_P0LIST);
5097           }
5098      }
5099
5100      default:
5101           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5102           Error_0(sc,sc->strbuff);
5103
5104      }
5105      return sc->T;
5106 }
5107
5108 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
5109      pointer x, y;
5110      long v;
5111
5112      switch (op) {
5113      CASE(OP_LIST_LENGTH):     /* length */   /* a.k */
5114           v=list_length(sc,car(sc->args));
5115           if(v<0) {
5116                Error_1(sc,"length: not a list:",car(sc->args));
5117           }
5118           gc_disable(sc, 1);
5119           s_return_enable_gc(sc, mk_integer(sc, v));
5120
5121      CASE(OP_ASSQ):       /* assq */     /* a.k */
5122           x = car(sc->args);
5123           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
5124                if (!is_pair(car(y))) {
5125                     Error_0(sc,"unable to handle non pair element");
5126                }
5127                if (x == caar(y))
5128                     break;
5129           }
5130           if (is_pair(y)) {
5131                s_return(sc,car(y));
5132           } else {
5133                s_return(sc,sc->F);
5134           }
5135
5136
5137      CASE(OP_GET_CLOSURE):     /* get-closure-code */   /* a.k */
5138           sc->args = car(sc->args);
5139           if (sc->args == sc->NIL) {
5140                s_return(sc,sc->F);
5141           } else if (is_closure(sc->args)) {
5142                gc_disable(sc, 1);
5143                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5144                                            closure_code(sc->value)));
5145           } else if (is_macro(sc->args)) {
5146                gc_disable(sc, 1);
5147                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5148                                            closure_code(sc->value)));
5149           } else {
5150                s_return(sc,sc->F);
5151           }
5152      CASE(OP_CLOSUREP):        /* closure? */
5153           /*
5154            * Note, macro object is also a closure.
5155            * Therefore, (closure? <#MACRO>) ==> #t
5156            */
5157           s_retbool(is_closure(car(sc->args)));
5158      CASE(OP_MACROP):          /* macro? */
5159           s_retbool(is_macro(car(sc->args)));
5160      CASE(OP_VM_HISTORY):          /* *vm-history* */
5161           s_return(sc, history_flatten(sc));
5162      default:
5163           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5164           Error_0(sc,sc->strbuff);
5165      }
5166      return sc->T; /* NOTREACHED */
5167 }
5168
5169 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
5170
5171 typedef int (*test_predicate)(pointer);
5172
5173 static int is_any(pointer p) {
5174    (void)p;
5175    return 1;
5176 }
5177
5178 static int is_nonneg(pointer p) {
5179   return ivalue(p)>=0 && is_integer(p);
5180 }
5181
5182 /* Correspond carefully with following defines! */
5183 static struct {
5184   test_predicate fct;
5185   const char *kind;
5186 } tests[]={
5187   {0,0}, /* unused */
5188   {is_any, 0},
5189   {is_string, "string"},
5190   {is_symbol, "symbol"},
5191   {is_port, "port"},
5192   {is_inport,"input port"},
5193   {is_outport,"output port"},
5194   {is_environment, "environment"},
5195   {is_pair, "pair"},
5196   {0, "pair or '()"},
5197   {is_character, "character"},
5198   {is_vector, "vector"},
5199   {is_number, "number"},
5200   {is_integer, "integer"},
5201   {is_nonneg, "non-negative integer"}
5202 };
5203
5204 #define TST_NONE 0
5205 #define TST_ANY "\001"
5206 #define TST_STRING "\002"
5207 #define TST_SYMBOL "\003"
5208 #define TST_PORT "\004"
5209 #define TST_INPORT "\005"
5210 #define TST_OUTPORT "\006"
5211 #define TST_ENVIRONMENT "\007"
5212 #define TST_PAIR "\010"
5213 #define TST_LIST "\011"
5214 #define TST_CHAR "\012"
5215 #define TST_VECTOR "\013"
5216 #define TST_NUMBER "\014"
5217 #define TST_INTEGER "\015"
5218 #define TST_NATURAL "\016"
5219
5220 typedef struct {
5221   dispatch_func func;
5222   char *name;
5223   int min_arity;
5224   int max_arity;
5225   char *arg_tests_encoding;
5226 } op_code_info;
5227
5228 #define INF_ARG 0xffff
5229
5230 static op_code_info dispatch_table[]= {
5231 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
5232 #include "opdefines.h"
5233   { 0 }
5234 };
5235
5236 static const char *procname(pointer x) {
5237  int n=procnum(x);
5238  const char *name=dispatch_table[n].name;
5239  if(name==0) {
5240      name="ILLEGAL!";
5241  }
5242  return name;
5243 }
5244
5245 /* kernel of this interpreter */
5246 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
5247   sc->op = op;
5248   for (;;) {
5249     op_code_info *pcd=dispatch_table+sc->op;
5250     if (pcd->name!=0) { /* if built-in function, check arguments */
5251       char msg[STRBUFFSIZE];
5252       int ok=1;
5253       int n=list_length(sc,sc->args);
5254
5255       /* Check number of arguments */
5256       if(n<pcd->min_arity) {
5257         ok=0;
5258         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5259         pcd->name,
5260         pcd->min_arity==pcd->max_arity?"":" at least",
5261         pcd->min_arity);
5262       }
5263       if(ok && n>pcd->max_arity) {
5264         ok=0;
5265         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5266         pcd->name,
5267         pcd->min_arity==pcd->max_arity?"":" at most",
5268         pcd->max_arity);
5269       }
5270       if(ok) {
5271         if(pcd->arg_tests_encoding!=0) {
5272           int i=0;
5273           int j;
5274           const char *t=pcd->arg_tests_encoding;
5275           pointer arglist=sc->args;
5276           do {
5277             pointer arg=car(arglist);
5278             j=(int)t[0];
5279             if(j==TST_LIST[0]) {
5280                   if(arg!=sc->NIL && !is_pair(arg)) break;
5281             } else {
5282               if(!tests[j].fct(arg)) break;
5283             }
5284
5285             if(t[1]!=0) {/* last test is replicated as necessary */
5286               t++;
5287             }
5288             arglist=cdr(arglist);
5289             i++;
5290           } while(i<n);
5291           if(i<n) {
5292             ok=0;
5293             snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
5294                 pcd->name,
5295                 i+1,
5296                 tests[j].kind,
5297                 type_to_string(type(car(arglist))));
5298           }
5299         }
5300       }
5301       if(!ok) {
5302         if(_Error_1(sc,msg,0)==sc->NIL) {
5303           return;
5304         }
5305         pcd=dispatch_table+sc->op;
5306       }
5307     }
5308     ok_to_freely_gc(sc);
5309     if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
5310       return;
5311     }
5312     if(sc->no_memory) {
5313       fprintf(stderr,"No memory!\n");
5314       exit(1);
5315     }
5316   }
5317 }
5318
5319 /* ========== Initialization of internal keywords ========== */
5320
5321 static void assign_syntax(scheme *sc, char *name) {
5322      pointer x;
5323
5324      x = oblist_add_by_name(sc, name);
5325      typeflag(x) |= T_SYNTAX;
5326 }
5327
5328 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
5329      pointer x, y;
5330
5331      x = mk_symbol(sc, name);
5332      y = mk_proc(sc,op);
5333      new_slot_in_env(sc, x, y);
5334 }
5335
5336 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
5337      pointer y;
5338
5339      y = get_cell(sc, sc->NIL, sc->NIL);
5340      typeflag(y) = (T_PROC | T_ATOM);
5341      ivalue_unchecked(y) = (long) op;
5342      set_num_integer(y);
5343      return y;
5344 }
5345
5346 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5347 static int syntaxnum(pointer p) {
5348      const char *s=strvalue(car(p));
5349      switch(strlength(car(p))) {
5350      case 2:
5351           if(s[0]=='i') return OP_IF0;        /* if */
5352           else return OP_OR0;                 /* or */
5353      case 3:
5354           if(s[0]=='a') return OP_AND0;      /* and */
5355           else return OP_LET0;               /* let */
5356      case 4:
5357           switch(s[3]) {
5358           case 'e': return OP_CASE0;         /* case */
5359           case 'd': return OP_COND0;         /* cond */
5360           case '*': return OP_LET0AST;       /* let* */
5361           default: return OP_SET0;           /* set! */
5362           }
5363      case 5:
5364           switch(s[2]) {
5365           case 'g': return OP_BEGIN;         /* begin */
5366           case 'l': return OP_DELAY;         /* delay */
5367           case 'c': return OP_MACRO0;        /* macro */
5368           default: return OP_QUOTE;          /* quote */
5369           }
5370      case 6:
5371           switch(s[2]) {
5372           case 'm': return OP_LAMBDA;        /* lambda */
5373           case 'f': return OP_DEF0;          /* define */
5374           default: return OP_LET0REC;        /* letrec */
5375           }
5376      default:
5377           return OP_C0STREAM;                /* cons-stream */
5378      }
5379 }
5380
5381 /* initialization of TinyScheme */
5382 #if USE_INTERFACE
5383 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
5384  return cons(sc,a,b);
5385 }
5386 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
5387  return immutable_cons(sc,a,b);
5388 }
5389
5390 static struct scheme_interface vtbl ={
5391   scheme_define,
5392   s_cons,
5393   s_immutable_cons,
5394   reserve_cells,
5395   mk_integer,
5396   mk_real,
5397   mk_symbol,
5398   gensym,
5399   mk_string,
5400   mk_counted_string,
5401   mk_character,
5402   mk_vector,
5403   mk_foreign_func,
5404   mk_foreign_object,
5405   get_foreign_object_vtable,
5406   get_foreign_object_data,
5407   putstr,
5408   putcharacter,
5409
5410   is_string,
5411   string_value,
5412   is_number,
5413   nvalue,
5414   ivalue,
5415   rvalue,
5416   is_integer,
5417   is_real,
5418   is_character,
5419   charvalue,
5420   is_list,
5421   is_vector,
5422   list_length,
5423   ivalue,
5424   fill_vector,
5425   vector_elem,
5426   set_vector_elem,
5427   is_port,
5428   is_pair,
5429   pair_car,
5430   pair_cdr,
5431   set_car,
5432   set_cdr,
5433
5434   is_symbol,
5435   symname,
5436
5437   is_syntax,
5438   is_proc,
5439   is_foreign,
5440   syntaxname,
5441   is_closure,
5442   is_macro,
5443   closure_code,
5444   closure_env,
5445
5446   is_continuation,
5447   is_promise,
5448   is_environment,
5449   is_immutable,
5450   setimmutable,
5451
5452   scheme_load_file,
5453   scheme_load_string,
5454   port_from_file
5455 };
5456 #endif
5457
5458 scheme *scheme_init_new() {
5459   scheme *sc=(scheme*)malloc(sizeof(scheme));
5460   if(!scheme_init(sc)) {
5461     free(sc);
5462     return 0;
5463   } else {
5464     return sc;
5465   }
5466 }
5467
5468 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
5469   scheme *sc=(scheme*)malloc(sizeof(scheme));
5470   if(!scheme_init_custom_alloc(sc,malloc,free)) {
5471     free(sc);
5472     return 0;
5473   } else {
5474     return sc;
5475   }
5476 }
5477
5478
5479 int scheme_init(scheme *sc) {
5480  return scheme_init_custom_alloc(sc,malloc,free);
5481 }
5482
5483 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
5484   int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
5485   pointer x;
5486
5487   num_zero.is_fixnum=1;
5488   num_zero.value.ivalue=0;
5489   num_one.is_fixnum=1;
5490   num_one.value.ivalue=1;
5491
5492 #if USE_INTERFACE
5493   sc->vptr=&vtbl;
5494 #endif
5495   sc->gensym_cnt=0;
5496   sc->malloc=malloc;
5497   sc->free=free;
5498   sc->last_cell_seg = -1;
5499   sc->sink = &sc->_sink;
5500   sc->NIL = &sc->_NIL;
5501   sc->T = &sc->_HASHT;
5502   sc->F = &sc->_HASHF;
5503   sc->EOF_OBJ=&sc->_EOF_OBJ;
5504
5505 #if USE_SMALL_INTEGERS
5506   if (initialize_small_integers(sc)) {
5507     sc->no_memory=1;
5508     return 0;
5509   }
5510 #endif
5511
5512   sc->free_cell = &sc->_NIL;
5513   sc->fcells = 0;
5514   sc->inhibit_gc = GC_ENABLED;
5515   sc->reserved_cells = 0;
5516   sc->reserved_lineno = 0;
5517   sc->no_memory=0;
5518   sc->inport=sc->NIL;
5519   sc->outport=sc->NIL;
5520   sc->save_inport=sc->NIL;
5521   sc->loadport=sc->NIL;
5522   sc->nesting=0;
5523   memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
5524   sc->interactive_repl=0;
5525   sc->strbuff = sc->malloc(STRBUFFSIZE);
5526   if (sc->strbuff == 0) {
5527      sc->no_memory=1;
5528      return 0;
5529   }
5530   sc->strbuff_size = STRBUFFSIZE;
5531
5532   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
5533     sc->no_memory=1;
5534     return 0;
5535   }
5536   sc->gc_verbose = 0;
5537   dump_stack_initialize(sc);
5538   sc->code = sc->NIL;
5539   sc->tracing=0;
5540   sc->op = -1;
5541   sc->flags = 0;
5542
5543   /* init sc->NIL */
5544   typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
5545   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
5546   /* init T */
5547   typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
5548   car(sc->T) = cdr(sc->T) = sc->T;
5549   /* init F */
5550   typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
5551   car(sc->F) = cdr(sc->F) = sc->F;
5552   /* init EOF_OBJ */
5553   typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
5554   car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
5555   /* init sink */
5556   typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
5557   car(sc->sink) = cdr(sc->sink) = sc->NIL;
5558   /* init c_nest */
5559   sc->c_nest = sc->NIL;
5560
5561   sc->oblist = oblist_initial_value(sc);
5562   /* init global_env */
5563   new_frame_in_env(sc, sc->NIL);
5564   sc->global_env = sc->envir;
5565   /* init else */
5566   x = mk_symbol(sc,"else");
5567   new_slot_in_env(sc, x, sc->T);
5568
5569   assign_syntax(sc, "lambda");
5570   assign_syntax(sc, "quote");
5571   assign_syntax(sc, "define");
5572   assign_syntax(sc, "if");
5573   assign_syntax(sc, "begin");
5574   assign_syntax(sc, "set!");
5575   assign_syntax(sc, "let");
5576   assign_syntax(sc, "let*");
5577   assign_syntax(sc, "letrec");
5578   assign_syntax(sc, "cond");
5579   assign_syntax(sc, "delay");
5580   assign_syntax(sc, "and");
5581   assign_syntax(sc, "or");
5582   assign_syntax(sc, "cons-stream");
5583   assign_syntax(sc, "macro");
5584   assign_syntax(sc, "case");
5585
5586   for(i=0; i<n; i++) {
5587     if(dispatch_table[i].name!=0) {
5588       assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
5589     }
5590   }
5591
5592   history_init(sc, 8, 8);
5593
5594   /* initialization of global pointers to special symbols */
5595   sc->LAMBDA = mk_symbol(sc, "lambda");
5596   sc->QUOTE = mk_symbol(sc, "quote");
5597   sc->QQUOTE = mk_symbol(sc, "quasiquote");
5598   sc->UNQUOTE = mk_symbol(sc, "unquote");
5599   sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
5600   sc->FEED_TO = mk_symbol(sc, "=>");
5601   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
5602   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
5603   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
5604 #if USE_COMPILE_HOOK
5605   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
5606 #endif
5607
5608   return !sc->no_memory;
5609 }
5610
5611 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
5612   sc->inport=port_from_file(sc,fin,port_input);
5613 }
5614
5615 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
5616   sc->inport=port_from_string(sc,start,past_the_end,port_input);
5617 }
5618
5619 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
5620   sc->outport=port_from_file(sc,fout,port_output);
5621 }
5622
5623 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
5624   sc->outport=port_from_string(sc,start,past_the_end,port_output);
5625 }
5626
5627 void scheme_set_external_data(scheme *sc, void *p) {
5628  sc->ext_data=p;
5629 }
5630
5631 void scheme_deinit(scheme *sc) {
5632   int i;
5633
5634   sc->oblist=sc->NIL;
5635   sc->global_env=sc->NIL;
5636   dump_stack_free(sc);
5637   sc->envir=sc->NIL;
5638   sc->code=sc->NIL;
5639   history_free(sc);
5640   sc->args=sc->NIL;
5641   sc->value=sc->NIL;
5642   if(is_port(sc->inport)) {
5643     typeflag(sc->inport) = T_ATOM;
5644   }
5645   sc->inport=sc->NIL;
5646   sc->outport=sc->NIL;
5647   if(is_port(sc->save_inport)) {
5648     typeflag(sc->save_inport) = T_ATOM;
5649   }
5650   sc->save_inport=sc->NIL;
5651   if(is_port(sc->loadport)) {
5652     typeflag(sc->loadport) = T_ATOM;
5653   }
5654   sc->loadport=sc->NIL;
5655
5656 #if SHOW_ERROR_LINE
5657   for(i=0; i<=sc->file_i; i++) {
5658     if (sc->load_stack[i].kind & port_file)
5659       port_clear_location(sc, &sc->load_stack[i]);
5660   }
5661 #endif
5662
5663   sc->gc_verbose=0;
5664   gc(sc,sc->NIL,sc->NIL);
5665
5666 #if USE_SMALL_INTEGERS
5667   sc->free(sc->integer_alloc);
5668 #endif
5669
5670   for(i=0; i<=sc->last_cell_seg; i++) {
5671     sc->free(sc->alloc_seg[i]);
5672   }
5673   sc->free(sc->strbuff);
5674 }
5675
5676 void scheme_load_file(scheme *sc, FILE *fin)
5677 { scheme_load_named_file(sc,fin,0); }
5678
5679 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
5680   dump_stack_reset(sc);
5681   sc->envir = sc->global_env;
5682   sc->file_i=0;
5683   sc->load_stack[0].kind=port_input|port_file;
5684   sc->load_stack[0].rep.stdio.file=fin;
5685   sc->loadport=mk_port(sc,sc->load_stack);
5686   sc->retcode=0;
5687   if(fin==stdin) {
5688     sc->interactive_repl=1;
5689   }
5690
5691 #if SHOW_ERROR_LINE
5692   port_reset_current_line(sc, &sc->load_stack[0]);
5693   if(fin!=stdin && filename)
5694     sc->load_stack[0].rep.stdio.filename = mk_string(sc, filename);
5695   else
5696     sc->load_stack[0].rep.stdio.filename = mk_string(sc, "<unknown>");
5697 #endif
5698
5699   sc->inport=sc->loadport;
5700   sc->args = mk_integer(sc,sc->file_i);
5701   Eval_Cycle(sc, OP_T0LVL);
5702   typeflag(sc->loadport)=T_ATOM;
5703   if(sc->retcode==0) {
5704     sc->retcode=sc->nesting!=0;
5705   }
5706
5707 #if SHOW_ERROR_LINE
5708   port_clear_location(sc, &sc->load_stack[0]);
5709 #endif
5710 }
5711
5712 void scheme_load_string(scheme *sc, const char *cmd) {
5713   dump_stack_reset(sc);
5714   sc->envir = sc->global_env;
5715   sc->file_i=0;
5716   sc->load_stack[0].kind=port_input|port_string;
5717   sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
5718   sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
5719   sc->load_stack[0].rep.string.curr=(char*)cmd;
5720   sc->loadport=mk_port(sc,sc->load_stack);
5721   sc->retcode=0;
5722   sc->interactive_repl=0;
5723   sc->inport=sc->loadport;
5724   sc->args = mk_integer(sc,sc->file_i);
5725   Eval_Cycle(sc, OP_T0LVL);
5726   typeflag(sc->loadport)=T_ATOM;
5727   if(sc->retcode==0) {
5728     sc->retcode=sc->nesting!=0;
5729   }
5730 }
5731
5732 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
5733      pointer x;
5734
5735      x=find_slot_in_env(sc,envir,symbol,0);
5736      if (x != sc->NIL) {
5737           set_slot_in_env(sc, x, value);
5738      } else {
5739           new_slot_spec_in_env(sc, envir, symbol, value);
5740      }
5741 }
5742
5743 #if !STANDALONE
5744 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
5745 {
5746   scheme_define(sc,
5747                 sc->global_env,
5748                 mk_symbol(sc,sr->name),
5749                 mk_foreign_func(sc, sr->f));
5750 }
5751
5752 void scheme_register_foreign_func_list(scheme * sc,
5753                                        scheme_registerable * list,
5754                                        int count)
5755 {
5756   int i;
5757   for(i = 0; i < count; i++)
5758     {
5759       scheme_register_foreign_func(sc, list + i);
5760     }
5761 }
5762
5763 pointer scheme_apply0(scheme *sc, const char *procname)
5764 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
5765
5766 void save_from_C_call(scheme *sc)
5767 {
5768   pointer saved_data =
5769     cons(sc,
5770          car(sc->sink),
5771          cons(sc,
5772               sc->envir,
5773               sc->dump));
5774   /* Push */
5775   sc->c_nest = cons(sc, saved_data, sc->c_nest);
5776   /* Truncate the dump stack so TS will return here when done, not
5777      directly resume pre-C-call operations. */
5778   dump_stack_reset(sc);
5779 }
5780 void restore_from_C_call(scheme *sc)
5781 {
5782   car(sc->sink) = caar(sc->c_nest);
5783   sc->envir = cadar(sc->c_nest);
5784   sc->dump = cdr(cdar(sc->c_nest));
5785   /* Pop */
5786   sc->c_nest = cdr(sc->c_nest);
5787 }
5788
5789 /* "func" and "args" are assumed to be already eval'ed. */
5790 pointer scheme_call(scheme *sc, pointer func, pointer args)
5791 {
5792   int old_repl = sc->interactive_repl;
5793   sc->interactive_repl = 0;
5794   save_from_C_call(sc);
5795   sc->envir = sc->global_env;
5796   sc->args = args;
5797   sc->code = func;
5798   sc->retcode = 0;
5799   Eval_Cycle(sc, OP_APPLY);
5800   sc->interactive_repl = old_repl;
5801   restore_from_C_call(sc);
5802   return sc->value;
5803 }
5804
5805 pointer scheme_eval(scheme *sc, pointer obj)
5806 {
5807   int old_repl = sc->interactive_repl;
5808   sc->interactive_repl = 0;
5809   save_from_C_call(sc);
5810   sc->args = sc->NIL;
5811   sc->code = obj;
5812   sc->retcode = 0;
5813   Eval_Cycle(sc, OP_EVAL);
5814   sc->interactive_repl = old_repl;
5815   restore_from_C_call(sc);
5816   return sc->value;
5817 }
5818
5819
5820 #endif
5821
5822 /* ========== Main ========== */
5823
5824 #if STANDALONE
5825
5826 #if defined(__APPLE__) && !defined (OSX)
5827 int main()
5828 {
5829      extern MacTS_main(int argc, char **argv);
5830      char**    argv;
5831      int argc = ccommand(&argv);
5832      MacTS_main(argc,argv);
5833      return 0;
5834 }
5835 int MacTS_main(int argc, char **argv) {
5836 #else
5837 int main(int argc, char **argv) {
5838 #endif
5839   scheme sc;
5840   FILE *fin;
5841   char *file_name=InitFile;
5842   int retcode;
5843   int isfile=1;
5844
5845   if(argc==1) {
5846     printf(banner);
5847   }
5848   if(argc==2 && strcmp(argv[1],"-?")==0) {
5849     printf("Usage: tinyscheme -?\n");
5850     printf("or:    tinyscheme [<file1> <file2> ...]\n");
5851     printf("followed by\n");
5852     printf("          -1 <file> [<arg1> <arg2> ...]\n");
5853     printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
5854     printf("assuming that the executable is named tinyscheme.\n");
5855     printf("Use - as filename for stdin.\n");
5856     return 1;
5857   }
5858   if(!scheme_init(&sc)) {
5859     fprintf(stderr,"Could not initialize!\n");
5860     return 2;
5861   }
5862   scheme_set_input_port_file(&sc, stdin);
5863   scheme_set_output_port_file(&sc, stdout);
5864 #if USE_DL
5865   scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
5866 #endif
5867   argv++;
5868   if(access(file_name,0)!=0) {
5869     char *p=getenv("TINYSCHEMEINIT");
5870     if(p!=0) {
5871       file_name=p;
5872     }
5873   }
5874   do {
5875     if(strcmp(file_name,"-")==0) {
5876       fin=stdin;
5877     } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
5878       pointer args=sc.NIL;
5879       isfile=file_name[1]=='1';
5880       file_name=*argv++;
5881       if(strcmp(file_name,"-")==0) {
5882         fin=stdin;
5883       } else if(isfile) {
5884         fin=fopen(file_name,"r");
5885       }
5886       for(;*argv;argv++) {
5887         pointer value=mk_string(&sc,*argv);
5888         args=cons(&sc,value,args);
5889       }
5890       args=reverse_in_place(&sc,sc.NIL,args);
5891       scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
5892
5893     } else {
5894       fin=fopen(file_name,"r");
5895     }
5896     if(isfile && fin==0) {
5897       fprintf(stderr,"Could not open file %s\n",file_name);
5898     } else {
5899       if(isfile) {
5900         scheme_load_named_file(&sc,fin,file_name);
5901       } else {
5902         scheme_load_string(&sc,file_name);
5903       }
5904       if(!isfile || fin!=stdin) {
5905         if(sc.retcode!=0) {
5906           fprintf(stderr,"Errors encountered reading %s\n",file_name);
5907         }
5908         if(isfile) {
5909           fclose(fin);
5910         }
5911       }
5912     }
5913     file_name=*argv++;
5914   } while(file_name!=0);
5915   if(argc==1) {
5916     scheme_load_named_file(&sc,stdin,0);
5917   }
5918   retcode=sc.retcode;
5919   scheme_deinit(&sc);
5920
5921   return retcode;
5922 }
5923
5924 #endif
5925
5926 /*
5927 Local variables:
5928 c-file-style: "k&r"
5929 End:
5930 */