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, const char *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      /* Mark tag if p has one.  */
1556      if (has_tag(p))
1557        mark(p + 1);
1558      if (is_atom(p))
1559           goto E6;
1560      /* E4: down car */
1561      q = car(p);
1562      if (q && !is_mark(q)) {
1563           setatom(p);  /* a note that we have moved car */
1564           car(p) = t;
1565           t = p;
1566           p = q;
1567           goto E2;
1568      }
1569 E5:  q = cdr(p); /* down cdr */
1570      if (q && !is_mark(q)) {
1571           cdr(p) = t;
1572           t = p;
1573           p = q;
1574           goto E2;
1575      }
1576 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1577      if (!t)
1578           return;
1579      q = t;
1580      if (is_atom(q)) {
1581           clratom(q);
1582           t = car(q);
1583           car(q) = p;
1584           p = q;
1585           goto E5;
1586      } else {
1587           t = cdr(q);
1588           cdr(q) = p;
1589           p = q;
1590           goto E6;
1591      }
1592 }
1593
1594 /* garbage collection. parameter a, b is marked. */
1595 static void gc(scheme *sc, pointer a, pointer b) {
1596   pointer p;
1597   int i;
1598
1599   assert (gc_enabled (sc));
1600
1601   if(sc->gc_verbose) {
1602     putstr(sc, "gc...");
1603   }
1604
1605   /* mark system globals */
1606   mark(sc->oblist);
1607   mark(sc->global_env);
1608
1609   /* mark current registers */
1610   mark(sc->args);
1611   mark(sc->envir);
1612   mark(sc->code);
1613   history_mark(sc);
1614   dump_stack_mark(sc);
1615   mark(sc->value);
1616   mark(sc->inport);
1617   mark(sc->save_inport);
1618   mark(sc->outport);
1619   mark(sc->loadport);
1620
1621   /* Mark recent objects the interpreter doesn't know about yet. */
1622   mark(car(sc->sink));
1623   /* Mark any older stuff above nested C calls */
1624   mark(sc->c_nest);
1625
1626   /* mark variables a, b */
1627   mark(a);
1628   mark(b);
1629
1630   /* garbage collect */
1631   clrmark(sc->NIL);
1632   sc->fcells = 0;
1633   sc->free_cell = sc->NIL;
1634   /* free-list is kept sorted by address so as to maintain consecutive
1635      ranges, if possible, for use with vectors. Here we scan the cells
1636      (which are also kept sorted by address) downwards to build the
1637      free-list in sorted order.
1638   */
1639   for (i = sc->last_cell_seg; i >= 0; i--) {
1640     p = sc->cell_seg[i] + CELL_SEGSIZE;
1641     while (--p >= sc->cell_seg[i]) {
1642       if (is_mark(p)) {
1643     clrmark(p);
1644       } else {
1645     /* reclaim cell */
1646         if (typeflag(p) & T_FINALIZE) {
1647           finalize_cell(sc, p);
1648         }
1649         ++sc->fcells;
1650         typeflag(p) = 0;
1651         car(p) = sc->NIL;
1652         cdr(p) = sc->free_cell;
1653         sc->free_cell = p;
1654       }
1655     }
1656   }
1657
1658   if (sc->gc_verbose) {
1659     char msg[80];
1660     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1661     putstr(sc,msg);
1662   }
1663 }
1664
1665 static void finalize_cell(scheme *sc, pointer a) {
1666   if(is_string(a)) {
1667     sc->free(strvalue(a));
1668   } else if(is_port(a)) {
1669     if(a->_object._port->kind&port_file
1670        && a->_object._port->rep.stdio.closeit) {
1671       port_close(sc,a,port_input|port_output);
1672     } else if (a->_object._port->kind & port_srfi6) {
1673       sc->free(a->_object._port->rep.string.start);
1674     }
1675     sc->free(a->_object._port);
1676   } else if(is_foreign_object(a)) {
1677     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1678   }
1679 }
1680
1681 /* ========== Routines for Reading ========== */
1682
1683 static int file_push(scheme *sc, const char *fname) {
1684   FILE *fin = NULL;
1685
1686   if (sc->file_i == MAXFIL-1)
1687      return 0;
1688   fin=fopen(fname,"r");
1689   if(fin!=0) {
1690     sc->file_i++;
1691     sc->load_stack[sc->file_i].kind=port_file|port_input;
1692     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1693     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1694     sc->nesting_stack[sc->file_i]=0;
1695     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1696
1697 #if SHOW_ERROR_LINE
1698     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1699     if(fname)
1700       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1701 #endif
1702   }
1703   return fin!=0;
1704 }
1705
1706 static void file_pop(scheme *sc) {
1707  if(sc->file_i != 0) {
1708    sc->nesting=sc->nesting_stack[sc->file_i];
1709    port_close(sc,sc->loadport,port_input);
1710    sc->file_i--;
1711    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1712  }
1713 }
1714
1715 static int file_interactive(scheme *sc) {
1716  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1717      && sc->inport->_object._port->kind&port_file;
1718 }
1719
1720 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1721   FILE *f;
1722   char *rw;
1723   port *pt;
1724   if(prop==(port_input|port_output)) {
1725     rw="a+";
1726   } else if(prop==port_output) {
1727     rw="w";
1728   } else {
1729     rw="r";
1730   }
1731   f=fopen(fn,rw);
1732   if(f==0) {
1733     return 0;
1734   }
1735   pt=port_rep_from_file(sc,f,prop);
1736   pt->rep.stdio.closeit=1;
1737
1738 #if SHOW_ERROR_LINE
1739   if(fn)
1740     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1741
1742   pt->rep.stdio.curr_line = 0;
1743 #endif
1744   return pt;
1745 }
1746
1747 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1748   port *pt;
1749   pt=port_rep_from_filename(sc,fn,prop);
1750   if(pt==0) {
1751     return sc->NIL;
1752   }
1753   return mk_port(sc,pt);
1754 }
1755
1756 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1757 {
1758     port *pt;
1759
1760     pt = (port *)sc->malloc(sizeof *pt);
1761     if (pt == NULL) {
1762         return NULL;
1763     }
1764     pt->kind = port_file | prop;
1765     pt->rep.stdio.file = f;
1766     pt->rep.stdio.closeit = 0;
1767     return pt;
1768 }
1769
1770 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1771   port *pt;
1772   pt=port_rep_from_file(sc,f,prop);
1773   if(pt==0) {
1774     return sc->NIL;
1775   }
1776   return mk_port(sc,pt);
1777 }
1778
1779 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1780   port *pt;
1781   pt=(port*)sc->malloc(sizeof(port));
1782   if(pt==0) {
1783     return 0;
1784   }
1785   pt->kind=port_string|prop;
1786   pt->rep.string.start=start;
1787   pt->rep.string.curr=start;
1788   pt->rep.string.past_the_end=past_the_end;
1789   return pt;
1790 }
1791
1792 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1793   port *pt;
1794   pt=port_rep_from_string(sc,start,past_the_end,prop);
1795   if(pt==0) {
1796     return sc->NIL;
1797   }
1798   return mk_port(sc,pt);
1799 }
1800
1801 #define BLOCK_SIZE 256
1802
1803 static port *port_rep_from_scratch(scheme *sc) {
1804   port *pt;
1805   char *start;
1806   pt=(port*)sc->malloc(sizeof(port));
1807   if(pt==0) {
1808     return 0;
1809   }
1810   start=sc->malloc(BLOCK_SIZE);
1811   if(start==0) {
1812     return 0;
1813   }
1814   memset(start,' ',BLOCK_SIZE-1);
1815   start[BLOCK_SIZE-1]='\0';
1816   pt->kind=port_string|port_output|port_srfi6;
1817   pt->rep.string.start=start;
1818   pt->rep.string.curr=start;
1819   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1820   return pt;
1821 }
1822
1823 static pointer port_from_scratch(scheme *sc) {
1824   port *pt;
1825   pt=port_rep_from_scratch(sc);
1826   if(pt==0) {
1827     return sc->NIL;
1828   }
1829   return mk_port(sc,pt);
1830 }
1831
1832 static void port_close(scheme *sc, pointer p, int flag) {
1833   port *pt=p->_object._port;
1834   pt->kind&=~flag;
1835   if((pt->kind & (port_input|port_output))==0) {
1836     if(pt->kind&port_file) {
1837
1838 #if SHOW_ERROR_LINE
1839       /* Cleanup is here so (close-*-port) functions could work too */
1840       pt->rep.stdio.curr_line = 0;
1841
1842       if(pt->rep.stdio.filename)
1843         sc->free(pt->rep.stdio.filename);
1844 #endif
1845
1846       fclose(pt->rep.stdio.file);
1847     }
1848     pt->kind=port_free;
1849   }
1850 }
1851
1852 /* get new character from input file */
1853 static int inchar(scheme *sc) {
1854   int c;
1855   port *pt;
1856
1857   pt = sc->inport->_object._port;
1858   if(pt->kind & port_saw_EOF)
1859     { return EOF; }
1860   c = basic_inchar(pt);
1861   if(c == EOF && sc->inport == sc->loadport) {
1862     /* Instead, set port_saw_EOF */
1863     pt->kind |= port_saw_EOF;
1864
1865     /* file_pop(sc); */
1866     return EOF;
1867     /* NOTREACHED */
1868   }
1869   return c;
1870 }
1871
1872 static int basic_inchar(port *pt) {
1873   if(pt->kind & port_file) {
1874     return fgetc(pt->rep.stdio.file);
1875   } else {
1876     if(*pt->rep.string.curr == 0 ||
1877        pt->rep.string.curr == pt->rep.string.past_the_end) {
1878       return EOF;
1879     } else {
1880       return *pt->rep.string.curr++;
1881     }
1882   }
1883 }
1884
1885 /* back character to input buffer */
1886 static void backchar(scheme *sc, int c) {
1887   port *pt;
1888   if(c==EOF) return;
1889   pt=sc->inport->_object._port;
1890   if(pt->kind&port_file) {
1891     ungetc(c,pt->rep.stdio.file);
1892   } else {
1893     if(pt->rep.string.curr!=pt->rep.string.start) {
1894       --pt->rep.string.curr;
1895     }
1896   }
1897 }
1898
1899 static int realloc_port_string(scheme *sc, port *p)
1900 {
1901   char *start=p->rep.string.start;
1902   size_t old_size = p->rep.string.past_the_end - start;
1903   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1904   char *str=sc->malloc(new_size);
1905   if(str) {
1906     memset(str,' ',new_size-1);
1907     str[new_size-1]='\0';
1908     memcpy(str, start, old_size);
1909     p->rep.string.start=str;
1910     p->rep.string.past_the_end=str+new_size-1;
1911     p->rep.string.curr-=start-str;
1912     sc->free(start);
1913     return 1;
1914   } else {
1915     return 0;
1916   }
1917 }
1918
1919 INTERFACE void putstr(scheme *sc, const char *s) {
1920   port *pt=sc->outport->_object._port;
1921   if(pt->kind&port_file) {
1922     fputs(s,pt->rep.stdio.file);
1923   } else {
1924     for(;*s;s++) {
1925       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1926         *pt->rep.string.curr++=*s;
1927       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1928         *pt->rep.string.curr++=*s;
1929       }
1930     }
1931   }
1932 }
1933
1934 static void putchars(scheme *sc, const char *s, int len) {
1935   port *pt=sc->outport->_object._port;
1936   if(pt->kind&port_file) {
1937     fwrite(s,1,len,pt->rep.stdio.file);
1938   } else {
1939     for(;len;len--) {
1940       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1941         *pt->rep.string.curr++=*s++;
1942       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1943         *pt->rep.string.curr++=*s++;
1944       }
1945     }
1946   }
1947 }
1948
1949 INTERFACE void putcharacter(scheme *sc, int c) {
1950   port *pt=sc->outport->_object._port;
1951   if(pt->kind&port_file) {
1952     fputc(c,pt->rep.stdio.file);
1953   } else {
1954     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1955       *pt->rep.string.curr++=c;
1956     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1957         *pt->rep.string.curr++=c;
1958     }
1959   }
1960 }
1961
1962 /* read characters up to delimiter, but cater to character constants */
1963 static char *readstr_upto(scheme *sc, char *delim) {
1964   char *p = sc->strbuff;
1965
1966   while ((p - sc->strbuff < sc->strbuff_size) &&
1967          !is_one_of(delim, (*p++ = inchar(sc))));
1968
1969   if(p == sc->strbuff+2 && p[-2] == '\\') {
1970     *p=0;
1971   } else {
1972     backchar(sc,p[-1]);
1973     *--p = '\0';
1974   }
1975   return sc->strbuff;
1976 }
1977
1978 /* read string expression "xxx...xxx" */
1979 static pointer readstrexp(scheme *sc) {
1980   char *p = sc->strbuff;
1981   int c;
1982   int c1=0;
1983   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1984
1985   for (;;) {
1986     c=inchar(sc);
1987     if(c == EOF) {
1988       return sc->F;
1989     }
1990     if(p-sc->strbuff > (sc->strbuff_size)-1) {
1991       ptrdiff_t offset = p - sc->strbuff;
1992       if (expand_strbuff(sc) != 0) {
1993         return sc->F;
1994       }
1995       p = sc->strbuff + offset;
1996     }
1997     switch(state) {
1998         case st_ok:
1999             switch(c) {
2000                 case '\\':
2001                     state=st_bsl;
2002                     break;
2003                 case '"':
2004                     *p=0;
2005                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
2006                 default:
2007                     *p++=c;
2008                     break;
2009             }
2010             break;
2011         case st_bsl:
2012             switch(c) {
2013                 case '0':
2014                 case '1':
2015                 case '2':
2016                 case '3':
2017                 case '4':
2018                 case '5':
2019                 case '6':
2020                 case '7':
2021                         state=st_oct1;
2022                         c1=c-'0';
2023                         break;
2024                 case 'x':
2025                 case 'X':
2026                     state=st_x1;
2027                     c1=0;
2028                     break;
2029                 case 'n':
2030                     *p++='\n';
2031                     state=st_ok;
2032                     break;
2033                 case 't':
2034                     *p++='\t';
2035                     state=st_ok;
2036                     break;
2037                 case 'r':
2038                     *p++='\r';
2039                     state=st_ok;
2040                     break;
2041                 case '"':
2042                     *p++='"';
2043                     state=st_ok;
2044                     break;
2045                 default:
2046                     *p++=c;
2047                     state=st_ok;
2048                     break;
2049             }
2050             break;
2051         case st_x1:
2052         case st_x2:
2053             c=toupper(c);
2054             if(c>='0' && c<='F') {
2055                 if(c<='9') {
2056                     c1=(c1<<4)+c-'0';
2057                 } else {
2058                     c1=(c1<<4)+c-'A'+10;
2059                 }
2060                 if(state==st_x1) {
2061                     state=st_x2;
2062                 } else {
2063                     *p++=c1;
2064                     state=st_ok;
2065                 }
2066             } else {
2067                 return sc->F;
2068             }
2069             break;
2070         case st_oct1:
2071         case st_oct2:
2072             if (c < '0' || c > '7')
2073             {
2074                    *p++=c1;
2075                    backchar(sc, c);
2076                    state=st_ok;
2077             }
2078             else
2079             {
2080                 if (state==st_oct2 && c1 >= 32)
2081                     return sc->F;
2082
2083                    c1=(c1<<3)+(c-'0');
2084
2085                 if (state == st_oct1)
2086                         state=st_oct2;
2087                 else
2088                 {
2089                         *p++=c1;
2090                         state=st_ok;
2091                    }
2092             }
2093             break;
2094
2095     }
2096   }
2097 }
2098
2099 /* check c is in chars */
2100 static INLINE int is_one_of(char *s, int c) {
2101      if(c==EOF) return 1;
2102      while (*s)
2103           if (*s++ == c)
2104                return (1);
2105      return (0);
2106 }
2107
2108 /* skip white characters */
2109 static INLINE int skipspace(scheme *sc) {
2110      int c = 0, curr_line = 0;
2111
2112      do {
2113          c=inchar(sc);
2114 #if SHOW_ERROR_LINE
2115          if(c=='\n')
2116            curr_line++;
2117 #endif
2118      } while (isspace(c));
2119
2120 /* record it */
2121 #if SHOW_ERROR_LINE
2122      if (sc->load_stack[sc->file_i].kind & port_file)
2123        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
2124 #endif
2125
2126      if(c!=EOF) {
2127           backchar(sc,c);
2128       return 1;
2129      }
2130      else
2131        { return EOF; }
2132 }
2133
2134 /* get token */
2135 static int token(scheme *sc) {
2136      int c;
2137      c = skipspace(sc);
2138      if(c == EOF) { return (TOK_EOF); }
2139      switch (c=inchar(sc)) {
2140      case EOF:
2141           return (TOK_EOF);
2142      case '(':
2143           return (TOK_LPAREN);
2144      case ')':
2145           return (TOK_RPAREN);
2146      case '.':
2147           c=inchar(sc);
2148           if(is_one_of(" \n\t",c)) {
2149                return (TOK_DOT);
2150           } else {
2151                backchar(sc,c);
2152                backchar(sc,'.');
2153                return TOK_ATOM;
2154           }
2155      case '\'':
2156           return (TOK_QUOTE);
2157      case ';':
2158            while ((c=inchar(sc)) != '\n' && c!=EOF)
2159              ;
2160
2161 #if SHOW_ERROR_LINE
2162            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2163              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2164 #endif
2165
2166        if(c == EOF)
2167          { return (TOK_EOF); }
2168        else
2169          { return (token(sc));}
2170      case '"':
2171           return (TOK_DQUOTE);
2172      case BACKQUOTE:
2173           return (TOK_BQUOTE);
2174      case ',':
2175          if ((c=inchar(sc)) == '@') {
2176                return (TOK_ATMARK);
2177          } else {
2178                backchar(sc,c);
2179                return (TOK_COMMA);
2180          }
2181      case '#':
2182           c=inchar(sc);
2183           if (c == '(') {
2184                return (TOK_VEC);
2185           } else if(c == '!') {
2186                while ((c=inchar(sc)) != '\n' && c!=EOF)
2187                    ;
2188
2189 #if SHOW_ERROR_LINE
2190            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2191              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2192 #endif
2193
2194            if(c == EOF)
2195              { return (TOK_EOF); }
2196            else
2197              { return (token(sc));}
2198           } else {
2199                backchar(sc,c);
2200                if(is_one_of(" tfodxb\\",c)) {
2201                     return TOK_SHARP_CONST;
2202                } else {
2203                     return (TOK_SHARP);
2204                }
2205           }
2206      default:
2207           backchar(sc,c);
2208           return (TOK_ATOM);
2209      }
2210 }
2211
2212 /* ========== Routines for Printing ========== */
2213 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
2214
2215 static void printslashstring(scheme *sc, char *p, int len) {
2216   int i;
2217   unsigned char *s=(unsigned char*)p;
2218   putcharacter(sc,'"');
2219   for ( i=0; i<len; i++) {
2220     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
2221       putcharacter(sc,'\\');
2222       switch(*s) {
2223       case '"':
2224         putcharacter(sc,'"');
2225         break;
2226       case '\n':
2227         putcharacter(sc,'n');
2228         break;
2229       case '\t':
2230         putcharacter(sc,'t');
2231         break;
2232       case '\r':
2233         putcharacter(sc,'r');
2234         break;
2235       case '\\':
2236         putcharacter(sc,'\\');
2237         break;
2238       default: {
2239           int d=*s/16;
2240           putcharacter(sc,'x');
2241           if(d<10) {
2242             putcharacter(sc,d+'0');
2243           } else {
2244             putcharacter(sc,d-10+'A');
2245           }
2246           d=*s%16;
2247           if(d<10) {
2248             putcharacter(sc,d+'0');
2249           } else {
2250             putcharacter(sc,d-10+'A');
2251           }
2252         }
2253       }
2254     } else {
2255       putcharacter(sc,*s);
2256     }
2257     s++;
2258   }
2259   putcharacter(sc,'"');
2260 }
2261
2262
2263 /* print atoms */
2264 static void printatom(scheme *sc, pointer l, int f) {
2265   char *p;
2266   int len;
2267   atom2str(sc,l,f,&p,&len);
2268   putchars(sc,p,len);
2269 }
2270
2271
2272 /* Uses internal buffer unless string pointer is already available */
2273 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2274      char *p;
2275
2276      if (l == sc->NIL) {
2277           p = "()";
2278      } else if (l == sc->T) {
2279           p = "#t";
2280      } else if (l == sc->F) {
2281           p = "#f";
2282      } else if (l == sc->EOF_OBJ) {
2283           p = "#<EOF>";
2284      } else if (is_port(l)) {
2285           p = "#<PORT>";
2286      } else if (is_number(l)) {
2287           p = sc->strbuff;
2288           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
2289               if(num_is_integer(l)) {
2290                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2291               } else {
2292                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2293                    /* r5rs says there must be a '.' (unless 'e'?) */
2294                    f = strcspn(p, ".e");
2295                    if (p[f] == 0) {
2296                         p[f] = '.'; /* not found, so add '.0' at the end */
2297                         p[f+1] = '0';
2298                         p[f+2] = 0;
2299                    }
2300               }
2301           } else {
2302               long v = ivalue(l);
2303               if (f == 16) {
2304                   if (v >= 0)
2305                     snprintf(p, STRBUFFSIZE, "%lx", v);
2306                   else
2307                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2308               } else if (f == 8) {
2309                   if (v >= 0)
2310                     snprintf(p, STRBUFFSIZE, "%lo", v);
2311                   else
2312                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2313               } else if (f == 2) {
2314                   unsigned long b = (v < 0) ? -v : v;
2315                   p = &p[STRBUFFSIZE-1];
2316                   *p = 0;
2317                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2318                   if (v < 0) *--p = '-';
2319               }
2320           }
2321      } else if (is_string(l)) {
2322           if (!f) {
2323                *pp = strvalue(l);
2324                *plen = strlength(l);
2325                return;
2326           } else { /* Hack, uses the fact that printing is needed */
2327                *pp=sc->strbuff;
2328                *plen=0;
2329                printslashstring(sc, strvalue(l), strlength(l));
2330                return;
2331           }
2332      } else if (is_character(l)) {
2333           int c=charvalue(l);
2334           p = sc->strbuff;
2335           if (!f) {
2336                p[0]=c;
2337                p[1]=0;
2338           } else {
2339                switch(c) {
2340                case ' ':
2341                     p = "#\\space";
2342                     break;
2343                case '\n':
2344                     p = "#\\newline";
2345                     break;
2346                case '\r':
2347                     p = "#\\return";
2348                     break;
2349                case '\t':
2350                     p = "#\\tab";
2351                     break;
2352                default:
2353 #if USE_ASCII_NAMES
2354                     if(c==127) {
2355                          p = "#\\del";
2356                          break;
2357                     } else if(c<32) {
2358                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2359                          break;
2360                     }
2361 #else
2362                     if(c<32) {
2363                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2364                       break;
2365                     }
2366 #endif
2367                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2368                     break;
2369                }
2370           }
2371      } else if (is_symbol(l)) {
2372           p = symname(l);
2373      } else if (is_proc(l)) {
2374           p = sc->strbuff;
2375           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2376      } else if (is_macro(l)) {
2377           p = "#<MACRO>";
2378      } else if (is_closure(l)) {
2379           p = "#<CLOSURE>";
2380      } else if (is_promise(l)) {
2381           p = "#<PROMISE>";
2382      } else if (is_foreign(l)) {
2383           p = sc->strbuff;
2384           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2385      } else if (is_continuation(l)) {
2386           p = "#<CONTINUATION>";
2387      } else if (is_foreign_object(l)) {
2388           p = sc->strbuff;
2389           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2390      } else {
2391           p = "#<ERROR>";
2392      }
2393      *pp=p;
2394      *plen=strlen(p);
2395 }
2396 /* ========== Routines for Evaluation Cycle ========== */
2397
2398 /* make closure. c is code. e is environment */
2399 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2400      pointer x = get_cell(sc, c, e);
2401
2402      typeflag(x) = T_CLOSURE;
2403      car(x) = c;
2404      cdr(x) = e;
2405      return (x);
2406 }
2407
2408 /* make continuation. */
2409 static pointer mk_continuation(scheme *sc, pointer d) {
2410      pointer x = get_cell(sc, sc->NIL, d);
2411
2412      typeflag(x) = T_CONTINUATION;
2413      cont_dump(x) = d;
2414      return (x);
2415 }
2416
2417 static pointer list_star(scheme *sc, pointer d) {
2418   pointer p, q;
2419   if(cdr(d)==sc->NIL) {
2420     return car(d);
2421   }
2422   p=cons(sc,car(d),cdr(d));
2423   q=p;
2424   while(cdr(cdr(p))!=sc->NIL) {
2425     d=cons(sc,car(p),cdr(p));
2426     if(cdr(cdr(p))!=sc->NIL) {
2427       p=cdr(d);
2428     }
2429   }
2430   cdr(p)=car(cdr(p));
2431   return q;
2432 }
2433
2434 /* reverse list -- produce new list */
2435 static pointer reverse(scheme *sc, pointer term, pointer list) {
2436 /* a must be checked by gc */
2437      pointer a = list, p = term;
2438
2439      for ( ; is_pair(a); a = cdr(a)) {
2440           p = cons(sc, car(a), p);
2441      }
2442      return (p);
2443 }
2444
2445 /* reverse list --- in-place */
2446 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2447      pointer p = list, result = term, q;
2448
2449      while (p != sc->NIL) {
2450           q = cdr(p);
2451           cdr(p) = result;
2452           result = p;
2453           p = q;
2454      }
2455      return (result);
2456 }
2457
2458 /* append list -- produce new list (in reverse order) */
2459 static pointer revappend(scheme *sc, pointer a, pointer b) {
2460     pointer result = a;
2461     pointer p = b;
2462
2463     while (is_pair(p)) {
2464         result = cons(sc, car(p), result);
2465         p = cdr(p);
2466     }
2467
2468     if (p == sc->NIL) {
2469         return result;
2470     }
2471
2472     return sc->F;   /* signal an error */
2473 }
2474
2475 /* equivalence of atoms */
2476 int eqv(pointer a, pointer b) {
2477      if (is_string(a)) {
2478           if (is_string(b))
2479                return (strvalue(a) == strvalue(b));
2480           else
2481                return (0);
2482      } else if (is_number(a)) {
2483           if (is_number(b)) {
2484                if (num_is_integer(a) == num_is_integer(b))
2485                     return num_eq(nvalue(a),nvalue(b));
2486           }
2487           return (0);
2488      } else if (is_character(a)) {
2489           if (is_character(b))
2490                return charvalue(a)==charvalue(b);
2491           else
2492                return (0);
2493      } else if (is_port(a)) {
2494           if (is_port(b))
2495                return a==b;
2496           else
2497                return (0);
2498      } else if (is_proc(a)) {
2499           if (is_proc(b))
2500                return procnum(a)==procnum(b);
2501           else
2502                return (0);
2503      } else {
2504           return (a == b);
2505      }
2506 }
2507
2508 /* true or false value macro */
2509 /* () is #t in R5RS */
2510 #define is_true(p)       ((p) != sc->F)
2511 #define is_false(p)      ((p) == sc->F)
2512
2513 /* ========== Environment implementation  ========== */
2514
2515 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2516
2517 static int hash_fn(const char *key, int table_size)
2518 {
2519   unsigned int hashed = 0;
2520   const char *c;
2521   int bits_per_int = sizeof(unsigned int)*8;
2522
2523   for (c = key; *c; c++) {
2524     /* letters have about 5 bits in them */
2525     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2526     hashed ^= *c;
2527   }
2528   return hashed % table_size;
2529 }
2530 #endif
2531
2532 #ifndef USE_ALIST_ENV
2533
2534 /*
2535  * In this implementation, each frame of the environment may be
2536  * a hash table: a vector of alists hashed by variable name.
2537  * In practice, we use a vector only for the initial frame;
2538  * subsequent frames are too small and transient for the lookup
2539  * speed to out-weigh the cost of making a new vector.
2540  */
2541
2542 static void new_frame_in_env(scheme *sc, pointer old_env)
2543 {
2544   pointer new_frame;
2545
2546   /* The interaction-environment has about 300 variables in it. */
2547   if (old_env == sc->NIL) {
2548     new_frame = mk_vector(sc, 461);
2549   } else {
2550     new_frame = sc->NIL;
2551   }
2552
2553   gc_disable(sc, 1);
2554   sc->envir = immutable_cons(sc, new_frame, old_env);
2555   gc_enable(sc);
2556   setenvironment(sc->envir);
2557 }
2558
2559 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2560                                         pointer variable, pointer value)
2561 {
2562 #define new_slot_spec_in_env_allocates  2
2563   pointer slot;
2564   gc_disable(sc, gc_reservations (new_slot_spec_in_env));
2565   slot = immutable_cons(sc, variable, value);
2566
2567   if (is_vector(car(env))) {
2568     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2569
2570     set_vector_elem(car(env), location,
2571                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2572   } else {
2573     car(env) = immutable_cons(sc, slot, car(env));
2574   }
2575   gc_enable(sc);
2576 }
2577
2578 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2579 {
2580   pointer x,y;
2581   int location;
2582
2583   for (x = env; x != sc->NIL; x = cdr(x)) {
2584     if (is_vector(car(x))) {
2585       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2586       y = vector_elem(car(x), location);
2587     } else {
2588       y = car(x);
2589     }
2590     for ( ; y != sc->NIL; y = cdr(y)) {
2591               if (caar(y) == hdl) {
2592                    break;
2593               }
2594          }
2595          if (y != sc->NIL) {
2596               break;
2597          }
2598          if(!all) {
2599            return sc->NIL;
2600          }
2601     }
2602     if (x != sc->NIL) {
2603           return car(y);
2604     }
2605     return sc->NIL;
2606 }
2607
2608 #else /* USE_ALIST_ENV */
2609
2610 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2611 {
2612   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2613   setenvironment(sc->envir);
2614 }
2615
2616 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2617                                         pointer variable, pointer value)
2618 {
2619   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2620 }
2621
2622 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2623 {
2624     pointer x,y;
2625     for (x = env; x != sc->NIL; x = cdr(x)) {
2626          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2627               if (caar(y) == hdl) {
2628                    break;
2629               }
2630          }
2631          if (y != sc->NIL) {
2632               break;
2633          }
2634          if(!all) {
2635            return sc->NIL;
2636          }
2637     }
2638     if (x != sc->NIL) {
2639           return car(y);
2640     }
2641     return sc->NIL;
2642 }
2643
2644 #endif /* USE_ALIST_ENV else */
2645
2646 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2647 {
2648 #define new_slot_in_env_allocates       new_slot_spec_in_env_allocates
2649   new_slot_spec_in_env(sc, sc->envir, variable, value);
2650 }
2651
2652 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2653 {
2654   (void)sc;
2655   cdr(slot) = value;
2656 }
2657
2658 static INLINE pointer slot_value_in_env(pointer slot)
2659 {
2660   return cdr(slot);
2661 }
2662
2663 /* ========== Evaluation Cycle ========== */
2664
2665
2666 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2667      const char *str = s;
2668      pointer history;
2669 #if USE_ERROR_HOOK
2670      pointer x;
2671      pointer hdl=sc->ERROR_HOOK;
2672 #endif
2673
2674 #if SHOW_ERROR_LINE
2675      char sbuf[STRBUFFSIZE];
2676 #endif
2677
2678      history = history_flatten(sc);
2679
2680 #if SHOW_ERROR_LINE
2681      /* make sure error is not in REPL */
2682      if (sc->load_stack[sc->file_i].kind & port_file &&
2683          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2684        pointer tag;
2685        const char *fname;
2686        int ln;
2687
2688        if (history != sc->NIL && has_tag(car(history))
2689            && (tag = get_tag(sc, car(history)))
2690            && is_string(car(tag)) && is_integer(cdr(tag))) {
2691          fname = string_value(car(tag));
2692          ln = ivalue_unchecked(cdr(tag));
2693        } else {
2694          fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2695          ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2696        }
2697
2698        /* should never happen */
2699        if(!fname) fname = "<unknown>";
2700
2701        /* we started from 0 */
2702        ln++;
2703        snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
2704
2705        str = (const char*)sbuf;
2706      }
2707 #endif
2708
2709 #if USE_ERROR_HOOK
2710      x=find_slot_in_env(sc,sc->envir,hdl,1);
2711     if (x != sc->NIL) {
2712          sc->code = cons(sc, cons(sc, sc->QUOTE,
2713                                   cons(sc, history, sc->NIL)),
2714                          sc->NIL);
2715          if(a!=0) {
2716            sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
2717                            sc->code);
2718          } else {
2719            sc->code = cons(sc, sc->F, sc->code);
2720          }
2721          sc->code = cons(sc, mk_string(sc, str), sc->code);
2722          setimmutable(car(sc->code));
2723          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2724          sc->op = (int)OP_EVAL;
2725          return sc->T;
2726     }
2727 #endif
2728
2729     if(a!=0) {
2730           sc->args = cons(sc, (a), sc->NIL);
2731     } else {
2732           sc->args = sc->NIL;
2733     }
2734     sc->args = cons(sc, mk_string(sc, str), sc->args);
2735     setimmutable(car(sc->args));
2736     sc->op = (int)OP_ERR0;
2737     return sc->T;
2738 }
2739 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2740 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2741
2742 /* Too small to turn into function */
2743 # define  BEGIN     do {
2744 # define  END  } while (0)
2745
2746 \f
2747
2748 /* Flags.  The interpreter has a flags field.  When the interpreter
2749  * pushes a frame to the dump stack, it is encoded with the opcode.
2750  * Therefore, we do not use the least significant byte.  */
2751
2752 /* Masks used to encode and decode opcode and flags.  */
2753 #define S_OP_MASK       0x000000ff
2754 #define S_FLAG_MASK     0xffffff00
2755
2756 /* Set if the interpreter evaluates an expression in a tail context
2757  * (see R5RS, section 3.5).  If a function, procedure, or continuation
2758  * is invoked while this flag is set, the call is recorded as tail
2759  * call in the history buffer.  */
2760 #define S_FLAG_TAIL_CONTEXT     0x00000100
2761
2762 /* Set flag F.  */
2763 #define s_set_flag(sc, f)                       \
2764            BEGIN                                \
2765            (sc)->flags |= S_FLAG_ ## f;         \
2766            END
2767
2768 /* Clear flag F.  */
2769 #define s_clear_flag(sc, f)                     \
2770            BEGIN                                \
2771            (sc)->flags &= ~ S_FLAG_ ## f;       \
2772            END
2773
2774 /* Check if flag F is set.  */
2775 #define s_get_flag(sc, f)                       \
2776            !!((sc)->flags & S_FLAG_ ## f)
2777
2778 \f
2779
2780 /* Bounce back to Eval_Cycle and execute A.  */
2781 #define s_goto(sc,a) BEGIN                                  \
2782     sc->op = (int)(a);                                      \
2783     return sc->T; END
2784
2785 #if USE_THREADED_CODE
2786
2787 /* Do not bounce back to Eval_Cycle but execute A by jumping directly
2788  * to it.  Only applicable if A is part of the same dispatch
2789  * function.  */
2790 #define s_thread_to(sc, a)      \
2791      BEGIN                      \
2792      op = (int) (a);            \
2793      goto a;                    \
2794      END
2795
2796 /* Define a label OP and emit a case statement for OP.  For use in the
2797  * dispatch functions.  The slightly peculiar goto that is never
2798  * executed avoids warnings about unused labels.  */
2799 #define CASE(OP)        if (0) goto OP; OP: case OP
2800
2801 #else   /* USE_THREADED_CODE */
2802 #define s_thread_to(sc, a)      s_goto(sc, a)
2803 #define CASE(OP)                case OP
2804 #endif  /* USE_THREADED_CODE */
2805
2806 /* Return to the previous frame on the dump stack, setting the current
2807  * value to A.  */
2808 #define s_return(sc, a) return _s_return(sc, a, 0)
2809
2810 /* Return to the previous frame on the dump stack, setting the current
2811  * value to A, and re-enable the garbage collector.  */
2812 #define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
2813
2814 static INLINE void dump_stack_reset(scheme *sc)
2815 {
2816   sc->dump = sc->NIL;
2817 }
2818
2819 static INLINE void dump_stack_initialize(scheme *sc)
2820 {
2821   dump_stack_reset(sc);
2822 }
2823
2824 static void dump_stack_free(scheme *sc)
2825 {
2826   sc->dump = sc->NIL;
2827 }
2828
2829 static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
2830   pointer dump = sc->dump;
2831   pointer op;
2832   unsigned long v;
2833   sc->value = (a);
2834   if (enable_gc)
2835        gc_enable(sc);
2836   if (dump == sc->NIL)
2837     return sc->NIL;
2838   free_cons(sc, dump, &op, &dump);
2839   v = (unsigned long) ivalue_unchecked(op);
2840   sc->op = (int) (v & S_OP_MASK);
2841   sc->flags = v & S_FLAG_MASK;
2842 #ifdef USE_SMALL_INTEGERS
2843   if (v < MAX_SMALL_INTEGER) {
2844     /* This is a small integer, we must not free it.  */
2845   } else
2846     /* Normal integer.  Recover the cell.  */
2847 #endif
2848     free_cell(sc, op);
2849   free_cons(sc, dump, &sc->args, &dump);
2850   free_cons(sc, dump, &sc->envir, &dump);
2851   free_cons(sc, dump, &sc->code, &sc->dump);
2852   return sc->T;
2853 }
2854
2855 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2856 #define s_save_allocates        5
2857     pointer dump;
2858     unsigned long v = sc->flags | ((unsigned long) op);
2859     gc_disable(sc, gc_reservations (s_save));
2860     dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2861     dump = cons(sc, (args), dump);
2862     sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
2863     gc_enable(sc);
2864 }
2865
2866 static INLINE void dump_stack_mark(scheme *sc)
2867 {
2868   mark(sc->dump);
2869 }
2870
2871 \f
2872
2873 #if USE_HISTORY
2874
2875 static void
2876 history_free(scheme *sc)
2877 {
2878   sc->free(sc->history.m);
2879   sc->history.tailstacks = sc->NIL;
2880   sc->history.callstack = sc->NIL;
2881 }
2882
2883 static pointer
2884 history_init(scheme *sc, size_t N, size_t M)
2885 {
2886   size_t i;
2887   struct history *h = &sc->history;
2888
2889   h->N = N;
2890   h->mask_N = N - 1;
2891   h->n = N - 1;
2892   assert ((N & h->mask_N) == 0);
2893
2894   h->M = M;
2895   h->mask_M = M - 1;
2896   assert ((M & h->mask_M) == 0);
2897
2898   h->callstack = mk_vector(sc, N);
2899   if (h->callstack == sc->sink)
2900     goto fail;
2901
2902   h->tailstacks = mk_vector(sc, N);
2903   for (i = 0; i < N; i++) {
2904     pointer tailstack = mk_vector(sc, M);
2905     if (tailstack == sc->sink)
2906       goto fail;
2907     set_vector_elem(h->tailstacks, i, tailstack);
2908   }
2909
2910   h->m = sc->malloc(N * sizeof *h->m);
2911   if (h->m == NULL)
2912     goto fail;
2913
2914   for (i = 0; i < N; i++)
2915     h->m[i] = 0;
2916
2917   return sc->T;
2918
2919 fail:
2920   history_free(sc);
2921   return sc->F;
2922 }
2923
2924 static void
2925 history_mark(scheme *sc)
2926 {
2927   struct history *h = &sc->history;
2928   mark(h->callstack);
2929   mark(h->tailstacks);
2930 }
2931
2932 #define add_mod(a, b, mask)     (((a) + (b)) & (mask))
2933 #define sub_mod(a, b, mask)     add_mod(a, (mask) + 1 - (b), mask)
2934
2935 static INLINE void
2936 tailstack_clear(scheme *sc, pointer v)
2937 {
2938   assert(is_vector(v));
2939   /* XXX optimize */
2940   fill_vector(v, sc->NIL);
2941 }
2942
2943 static pointer
2944 callstack_pop(scheme *sc)
2945 {
2946   struct history *h = &sc->history;
2947   size_t n = h->n;
2948   pointer item;
2949
2950   if (h->callstack == sc->NIL)
2951     return sc->NIL;
2952
2953   item = vector_elem(h->callstack, n);
2954   /* Clear our frame so that it can be gc'ed and we don't run into it
2955    * when walking the history.  */
2956   set_vector_elem(h->callstack, n, sc->NIL);
2957   tailstack_clear(sc, vector_elem(h->tailstacks, n));
2958
2959   /* Exit from the frame.  */
2960   h->n = sub_mod(h->n, 1, h->mask_N);
2961
2962   return item;
2963 }
2964
2965 static void
2966 callstack_push(scheme *sc, pointer item)
2967 {
2968   struct history *h = &sc->history;
2969   size_t n = h->n;
2970
2971   if (h->callstack == sc->NIL)
2972     return;
2973
2974   /* Enter a new frame.  */
2975   n = h->n = add_mod(n, 1, h->mask_N);
2976
2977   /* Initialize tail stack.  */
2978   tailstack_clear(sc, vector_elem(h->tailstacks, n));
2979   h->m[n] = h->mask_M;
2980
2981   set_vector_elem(h->callstack, n, item);
2982 }
2983
2984 static void
2985 tailstack_push(scheme *sc, pointer item)
2986 {
2987   struct history *h = &sc->history;
2988   size_t n = h->n;
2989   size_t m = h->m[n];
2990
2991   if (h->callstack == sc->NIL)
2992     return;
2993
2994   /* Enter a new tail frame.  */
2995   m = h->m[n] = add_mod(m, 1, h->mask_M);
2996   set_vector_elem(vector_elem(h->tailstacks, n), m, item);
2997 }
2998
2999 static pointer
3000 tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
3001                   pointer acc)
3002 {
3003   struct history *h = &sc->history;
3004   pointer frame;
3005
3006   assert(i <= h->M);
3007   assert(n < h->M);
3008
3009   if (acc == sc->sink)
3010     return sc->sink;
3011
3012   if (i == 0) {
3013     /* We reached the end, but we did not see a unused frame.  Signal
3014        this using '... .  */
3015     return cons(sc, mk_symbol(sc, "..."), acc);
3016   }
3017
3018   frame = vector_elem(tailstack, n);
3019   if (frame == sc->NIL) {
3020     /* A unused frame.  We reached the end of the history.  */
3021     return acc;
3022   }
3023
3024   /* Add us.  */
3025   acc = cons(sc, frame, acc);
3026
3027   return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
3028                            acc);
3029 }
3030
3031 static pointer
3032 callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
3033 {
3034   struct history *h = &sc->history;
3035   pointer frame;
3036
3037   assert(i <= h->N);
3038   assert(n < h->N);
3039
3040   if (acc == sc->sink)
3041     return sc->sink;
3042
3043   if (i == 0) {
3044     /* We reached the end, but we did not see a unused frame.  Signal
3045        this using '... .  */
3046     return cons(sc, mk_symbol(sc, "..."), acc);
3047   }
3048
3049   frame = vector_elem(h->callstack, n);
3050   if (frame == sc->NIL) {
3051     /* A unused frame.  We reached the end of the history.  */
3052     return acc;
3053   }
3054
3055   /* First, emit the tail calls.  */
3056   acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
3057                           acc);
3058
3059   /* Then us.  */
3060   acc = cons(sc, frame, acc);
3061
3062   return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
3063 }
3064
3065 static pointer
3066 history_flatten(scheme *sc)
3067 {
3068   struct history *h = &sc->history;
3069   pointer history;
3070
3071   if (h->callstack == sc->NIL)
3072     return sc->NIL;
3073
3074   history = callstack_flatten(sc, h->N, h->n, sc->NIL);
3075   if (history == sc->sink)
3076     return sc->sink;
3077
3078   return reverse_in_place(sc, sc->NIL, history);
3079 }
3080
3081 #undef add_mod
3082 #undef sub_mod
3083
3084 #else   /* USE_HISTORY */
3085
3086 #define history_init(SC, A, B)  (void) 0
3087 #define history_free(SC)        (void) 0
3088 #define callstack_pop(SC)       (void) 0
3089 #define callstack_push(SC, X)   (void) 0
3090 #define tailstack_push(SC, X)   (void) 0
3091
3092 #endif  /* USE_HISTORY */
3093
3094 \f
3095
3096 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
3097
3098 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
3099      pointer x, y;
3100      pointer callsite;
3101
3102      switch (op) {
3103      CASE(OP_LOAD):       /* load */
3104           if(file_interactive(sc)) {
3105                fprintf(sc->outport->_object._port->rep.stdio.file,
3106                "Loading %s\n", strvalue(car(sc->args)));
3107           }
3108           if (!file_push(sc,strvalue(car(sc->args)))) {
3109                Error_1(sc,"unable to open", car(sc->args));
3110           }
3111       else
3112         {
3113           sc->args = mk_integer(sc,sc->file_i);
3114           s_thread_to(sc,OP_T0LVL);
3115         }
3116
3117      CASE(OP_T0LVL): /* top level */
3118        /* If we reached the end of file, this loop is done. */
3119        if(sc->loadport->_object._port->kind & port_saw_EOF)
3120      {
3121        if(sc->file_i == 0)
3122          {
3123            sc->args=sc->NIL;
3124            sc->nesting = sc->nesting_stack[0];
3125            s_goto(sc,OP_QUIT);
3126          }
3127        else
3128          {
3129            file_pop(sc);
3130            s_return(sc,sc->value);
3131          }
3132        /* NOTREACHED */
3133      }
3134
3135        /* If interactive, be nice to user. */
3136        if(file_interactive(sc))
3137      {
3138        sc->envir = sc->global_env;
3139        dump_stack_reset(sc);
3140        putstr(sc,"\n");
3141        putstr(sc,prompt);
3142      }
3143
3144        /* Set up another iteration of REPL */
3145        sc->nesting=0;
3146        sc->save_inport=sc->inport;
3147        sc->inport = sc->loadport;
3148        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
3149        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
3150        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
3151        s_thread_to(sc,OP_READ_INTERNAL);
3152
3153      CASE(OP_T1LVL): /* top level */
3154           sc->code = sc->value;
3155           sc->inport=sc->save_inport;
3156           s_thread_to(sc,OP_EVAL);
3157
3158      CASE(OP_READ_INTERNAL):       /* internal read */
3159           sc->tok = token(sc);
3160           if(sc->tok==TOK_EOF)
3161         { s_return(sc,sc->EOF_OBJ); }
3162           s_goto(sc,OP_RDSEXPR);
3163
3164      CASE(OP_GENSYM):
3165           s_return(sc, gensym(sc));
3166
3167      CASE(OP_VALUEPRINT): /* print evaluation result */
3168           /* OP_VALUEPRINT is always pushed, because when changing from
3169              non-interactive to interactive mode, it needs to be
3170              already on the stack */
3171        if(sc->tracing) {
3172          putstr(sc,"\nGives: ");
3173        }
3174        if(file_interactive(sc)) {
3175          sc->print_flag = 1;
3176          sc->args = sc->value;
3177          s_goto(sc,OP_P0LIST);
3178        } else {
3179          s_return(sc,sc->value);
3180        }
3181
3182      CASE(OP_EVAL):       /* main part of evaluation */
3183 #if USE_TRACING
3184        if(sc->tracing) {
3185          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
3186          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
3187          sc->args=sc->code;
3188          putstr(sc,"\nEval: ");
3189          s_goto(sc,OP_P0LIST);
3190        }
3191        /* fall through */
3192      CASE(OP_REAL_EVAL):
3193 #endif
3194           if (is_symbol(sc->code)) {    /* symbol */
3195                x=find_slot_in_env(sc,sc->envir,sc->code,1);
3196                if (x != sc->NIL) {
3197                     s_return(sc,slot_value_in_env(x));
3198                } else {
3199                     Error_1(sc,"eval: unbound variable:", sc->code);
3200                }
3201           } else if (is_pair(sc->code)) {
3202                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
3203                     sc->code = cdr(sc->code);
3204                     s_goto(sc,syntaxnum(x));
3205                } else {/* first, eval top element and eval arguments */
3206                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
3207                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
3208                     sc->code = car(sc->code);
3209                     s_clear_flag(sc, TAIL_CONTEXT);
3210                     s_thread_to(sc,OP_EVAL);
3211                }
3212           } else {
3213                s_return(sc,sc->code);
3214           }
3215
3216      CASE(OP_E0ARGS):     /* eval arguments */
3217           if (is_macro(sc->value)) {    /* macro expansion */
3218                gc_disable(sc, 1 + gc_reservations (s_save));
3219                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
3220                sc->args = cons(sc,sc->code, sc->NIL);
3221                gc_enable(sc);
3222                sc->code = sc->value;
3223                s_clear_flag(sc, TAIL_CONTEXT);
3224                s_thread_to(sc,OP_APPLY);
3225           } else {
3226                gc_disable(sc, 1);
3227                sc->args = cons(sc, sc->code, sc->NIL);
3228                gc_enable(sc);
3229                sc->code = cdr(sc->code);
3230                s_thread_to(sc,OP_E1ARGS);
3231           }
3232
3233      CASE(OP_E1ARGS):     /* eval arguments */
3234           gc_disable(sc, 1);
3235           sc->args = cons(sc, sc->value, sc->args);
3236           gc_enable(sc);
3237           if (is_pair(sc->code)) { /* continue */
3238                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
3239                sc->code = car(sc->code);
3240                sc->args = sc->NIL;
3241                s_clear_flag(sc, TAIL_CONTEXT);
3242                s_thread_to(sc,OP_EVAL);
3243           } else {  /* end */
3244                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3245                s_thread_to(sc,OP_APPLY_CODE);
3246           }
3247
3248 #if USE_TRACING
3249      CASE(OP_TRACING): {
3250        int tr=sc->tracing;
3251        sc->tracing=ivalue(car(sc->args));
3252        gc_disable(sc, 1);
3253        s_return_enable_gc(sc, mk_integer(sc, tr));
3254      }
3255 #endif
3256
3257 #if USE_HISTORY
3258      CASE(OP_CALLSTACK_POP):      /* pop the call stack */
3259           callstack_pop(sc);
3260           s_return(sc, sc->value);
3261 #endif
3262
3263      CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
3264                            * record in the history as invoked from
3265                            * 'car(args)' */
3266           free_cons(sc, sc->args, &callsite, &sc->args);
3267           sc->code = car(sc->args);
3268           sc->args = cdr(sc->args);
3269           /* Fallthrough.  */
3270
3271      CASE(OP_APPLY):      /* apply 'code' to 'args' */
3272 #if USE_TRACING
3273        if(sc->tracing) {
3274          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
3275          sc->print_flag = 1;
3276          /*  sc->args=cons(sc,sc->code,sc->args);*/
3277          putstr(sc,"\nApply to: ");
3278          s_goto(sc,OP_P0LIST);
3279        }
3280        /* fall through */
3281      CASE(OP_REAL_APPLY):
3282 #endif
3283 #if USE_HISTORY
3284           if (op != OP_APPLY_CODE)
3285             callsite = sc->code;
3286           if (s_get_flag(sc, TAIL_CONTEXT)) {
3287             /* We are evaluating a tail call.  */
3288             tailstack_push(sc, callsite);
3289           } else {
3290             callstack_push(sc, callsite);
3291             s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
3292           }
3293 #endif
3294
3295           if (is_proc(sc->code)) {
3296                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
3297           } else if (is_foreign(sc->code))
3298             {
3299               /* Keep nested calls from GC'ing the arglist */
3300               push_recent_alloc(sc,sc->args,sc->NIL);
3301                x=sc->code->_object._ff(sc,sc->args);
3302                s_return(sc,x);
3303           } else if (is_closure(sc->code) || is_macro(sc->code)
3304              || is_promise(sc->code)) { /* CLOSURE */
3305         /* Should not accept promise */
3306                /* make environment */
3307                new_frame_in_env(sc, closure_env(sc->code));
3308                for (x = car(closure_code(sc->code)), y = sc->args;
3309                     is_pair(x); x = cdr(x), y = cdr(y)) {
3310                     if (y == sc->NIL) {
3311                          Error_1(sc, "not enough arguments, missing:", x);
3312                     } else {
3313                          new_slot_in_env(sc, car(x), car(y));
3314                     }
3315                }
3316                if (x == sc->NIL) {
3317                     /*--
3318                      * if (y != sc->NIL) {
3319                      *   Error_0(sc,"too many arguments");
3320                      * }
3321                      */
3322                } else if (is_symbol(x))
3323                     new_slot_in_env(sc, x, y);
3324                else {
3325                     Error_1(sc,"syntax error in closure: not a symbol:", x);
3326                }
3327                sc->code = cdr(closure_code(sc->code));
3328                sc->args = sc->NIL;
3329                s_set_flag(sc, TAIL_CONTEXT);
3330                s_thread_to(sc,OP_BEGIN);
3331           } else if (is_continuation(sc->code)) { /* CONTINUATION */
3332                sc->dump = cont_dump(sc->code);
3333                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
3334           } else {
3335                Error_1(sc,"illegal function",sc->code);
3336           }
3337
3338      CASE(OP_DOMACRO):    /* do macro */
3339           sc->code = sc->value;
3340           s_thread_to(sc,OP_EVAL);
3341
3342 #if USE_COMPILE_HOOK
3343      CASE(OP_LAMBDA):     /* lambda */
3344           /* If the hook is defined, apply it to sc->code, otherwise
3345              set sc->value fall through */
3346           {
3347                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
3348                if(f==sc->NIL) {
3349                     sc->value = sc->code;
3350                     /* Fallthru */
3351                } else {
3352                     gc_disable(sc, 1 + gc_reservations (s_save));
3353                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
3354                     sc->args=cons(sc,sc->code,sc->NIL);
3355                     gc_enable(sc);
3356                     sc->code=slot_value_in_env(f);
3357                     s_thread_to(sc,OP_APPLY);
3358                }
3359           }
3360
3361 #else
3362      CASE(OP_LAMBDA):     /* lambda */
3363           sc->value = sc->code;
3364           /* Fallthrough. */
3365 #endif
3366
3367      CASE(OP_LAMBDA1):
3368           gc_disable(sc, 1);
3369           s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
3370
3371
3372      CASE(OP_MKCLOSURE): /* make-closure */
3373        x=car(sc->args);
3374        if(car(x)==sc->LAMBDA) {
3375          x=cdr(x);
3376        }
3377        if(cdr(sc->args)==sc->NIL) {
3378          y=sc->envir;
3379        } else {
3380          y=cadr(sc->args);
3381        }
3382        gc_disable(sc, 1);
3383        s_return_enable_gc(sc, mk_closure(sc, x, y));
3384
3385      CASE(OP_QUOTE):      /* quote */
3386           s_return(sc,car(sc->code));
3387
3388      CASE(OP_DEF0):  /* define */
3389           if(is_immutable(car(sc->code)))
3390             Error_1(sc,"define: unable to alter immutable", car(sc->code));
3391
3392           if (is_pair(car(sc->code))) {
3393                x = caar(sc->code);
3394                gc_disable(sc, 2);
3395                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3396                gc_enable(sc);
3397           } else {
3398                x = car(sc->code);
3399                sc->code = cadr(sc->code);
3400           }
3401           if (!is_symbol(x)) {
3402                Error_0(sc,"variable is not a symbol");
3403           }
3404           s_save(sc,OP_DEF1, sc->NIL, x);
3405           s_thread_to(sc,OP_EVAL);
3406
3407      CASE(OP_DEF1):  /* define */
3408           x=find_slot_in_env(sc,sc->envir,sc->code,0);
3409           if (x != sc->NIL) {
3410                set_slot_in_env(sc, x, sc->value);
3411           } else {
3412                new_slot_in_env(sc, sc->code, sc->value);
3413           }
3414           s_return(sc,sc->code);
3415
3416
3417      CASE(OP_DEFP):  /* defined? */
3418           x=sc->envir;
3419           if(cdr(sc->args)!=sc->NIL) {
3420                x=cadr(sc->args);
3421           }
3422           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3423
3424      CASE(OP_SET0):       /* set! */
3425           if(is_immutable(car(sc->code)))
3426                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3427           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3428           sc->code = cadr(sc->code);
3429           s_thread_to(sc,OP_EVAL);
3430
3431      CASE(OP_SET1):       /* set! */
3432           y=find_slot_in_env(sc,sc->envir,sc->code,1);
3433           if (y != sc->NIL) {
3434                set_slot_in_env(sc, y, sc->value);
3435                s_return(sc,sc->value);
3436           } else {
3437                Error_1(sc,"set!: unbound variable:", sc->code);
3438           }
3439
3440
3441      CASE(OP_BEGIN):      /* begin */
3442           {
3443             int last;
3444
3445             if (!is_pair(sc->code)) {
3446               s_return(sc,sc->code);
3447             }
3448
3449             last = cdr(sc->code) == sc->NIL;
3450             if (!last) {
3451               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3452             }
3453             sc->code = car(sc->code);
3454             if (! last)
3455               /* This is not the end of the list.  This is not a tail
3456                * position.  */
3457               s_clear_flag(sc, TAIL_CONTEXT);
3458             s_thread_to(sc,OP_EVAL);
3459           }
3460
3461      CASE(OP_IF0):        /* if */
3462           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3463           sc->code = car(sc->code);
3464           s_clear_flag(sc, TAIL_CONTEXT);
3465           s_thread_to(sc,OP_EVAL);
3466
3467      CASE(OP_IF1):        /* if */
3468           if (is_true(sc->value))
3469                sc->code = car(sc->code);
3470           else
3471                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
3472                                             * car(sc->NIL) = sc->NIL */
3473           s_thread_to(sc,OP_EVAL);
3474
3475      CASE(OP_LET0):       /* let */
3476           sc->args = sc->NIL;
3477           sc->value = sc->code;
3478           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3479           s_thread_to(sc,OP_LET1);
3480
3481      CASE(OP_LET1):       /* let (calculate parameters) */
3482           gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3483           sc->args = cons(sc, sc->value, sc->args);
3484           if (is_pair(sc->code)) { /* continue */
3485                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3486                     gc_enable(sc);
3487                     Error_1(sc, "Bad syntax of binding spec in let :",
3488                             car(sc->code));
3489                }
3490                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
3491                gc_enable(sc);
3492                sc->code = cadar(sc->code);
3493                sc->args = sc->NIL;
3494                s_clear_flag(sc, TAIL_CONTEXT);
3495                s_thread_to(sc,OP_EVAL);
3496           } else {  /* end */
3497                gc_enable(sc);
3498                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3499                sc->code = car(sc->args);
3500                sc->args = cdr(sc->args);
3501                s_thread_to(sc,OP_LET2);
3502           }
3503
3504      CASE(OP_LET2):       /* let */
3505           new_frame_in_env(sc, sc->envir);
3506           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
3507                y != sc->NIL; x = cdr(x), y = cdr(y)) {
3508                new_slot_in_env(sc, caar(x), car(y));
3509           }
3510           if (is_symbol(car(sc->code))) {    /* named let */
3511                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
3512                     if (!is_pair(x))
3513                         Error_1(sc, "Bad syntax of binding in let :", x);
3514                     if (!is_list(sc, car(x)))
3515                         Error_1(sc, "Bad syntax of binding in let :", car(x));
3516                     gc_disable(sc, 1);
3517                     sc->args = cons(sc, caar(x), sc->args);
3518                     gc_enable(sc);
3519                }
3520                gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
3521                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
3522                new_slot_in_env(sc, car(sc->code), x);
3523                gc_enable(sc);
3524                sc->code = cddr(sc->code);
3525                sc->args = sc->NIL;
3526           } else {
3527                sc->code = cdr(sc->code);
3528                sc->args = sc->NIL;
3529           }
3530           s_thread_to(sc,OP_BEGIN);
3531
3532      CASE(OP_LET0AST):    /* let* */
3533           if (car(sc->code) == sc->NIL) {
3534                new_frame_in_env(sc, sc->envir);
3535                sc->code = cdr(sc->code);
3536                s_thread_to(sc,OP_BEGIN);
3537           }
3538           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
3539                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
3540           }
3541           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
3542           sc->code = cadaar(sc->code);
3543           s_clear_flag(sc, TAIL_CONTEXT);
3544           s_thread_to(sc,OP_EVAL);
3545
3546      CASE(OP_LET1AST):    /* let* (make new frame) */
3547           new_frame_in_env(sc, sc->envir);
3548           s_thread_to(sc,OP_LET2AST);
3549
3550      CASE(OP_LET2AST):    /* let* (calculate parameters) */
3551           new_slot_in_env(sc, caar(sc->code), sc->value);
3552           sc->code = cdr(sc->code);
3553           if (is_pair(sc->code)) { /* continue */
3554                s_save(sc,OP_LET2AST, sc->args, sc->code);
3555                sc->code = cadar(sc->code);
3556                sc->args = sc->NIL;
3557                s_clear_flag(sc, TAIL_CONTEXT);
3558                s_thread_to(sc,OP_EVAL);
3559           } else {  /* end */
3560                sc->code = sc->args;
3561                sc->args = sc->NIL;
3562                s_thread_to(sc,OP_BEGIN);
3563           }
3564      default:
3565           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3566           Error_0(sc,sc->strbuff);
3567      }
3568      return sc->T;
3569 }
3570
3571 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
3572      pointer x, y;
3573
3574      switch (op) {
3575      CASE(OP_LET0REC):    /* letrec */
3576           new_frame_in_env(sc, sc->envir);
3577           sc->args = sc->NIL;
3578           sc->value = sc->code;
3579           sc->code = car(sc->code);
3580           s_thread_to(sc,OP_LET1REC);
3581
3582      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
3583           gc_disable(sc, 1);
3584           sc->args = cons(sc, sc->value, sc->args);
3585           gc_enable(sc);
3586           if (is_pair(sc->code)) { /* continue */
3587                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3588                     Error_1(sc, "Bad syntax of binding spec in letrec :",
3589                             car(sc->code));
3590                }
3591                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
3592                sc->code = cadar(sc->code);
3593                sc->args = sc->NIL;
3594                s_clear_flag(sc, TAIL_CONTEXT);
3595                s_goto(sc,OP_EVAL);
3596           } else {  /* end */
3597                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3598                sc->code = car(sc->args);
3599                sc->args = cdr(sc->args);
3600                s_thread_to(sc,OP_LET2REC);
3601           }
3602
3603      CASE(OP_LET2REC):    /* letrec */
3604           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
3605                new_slot_in_env(sc, caar(x), car(y));
3606           }
3607           sc->code = cdr(sc->code);
3608           sc->args = sc->NIL;
3609           s_goto(sc,OP_BEGIN);
3610
3611      CASE(OP_COND0):      /* cond */
3612           if (!is_pair(sc->code)) {
3613                Error_0(sc,"syntax error in cond");
3614           }
3615           s_save(sc,OP_COND1, sc->NIL, sc->code);
3616           sc->code = caar(sc->code);
3617           s_clear_flag(sc, TAIL_CONTEXT);
3618           s_goto(sc,OP_EVAL);
3619
3620      CASE(OP_COND1):      /* cond */
3621           if (is_true(sc->value)) {
3622                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3623                     s_return(sc,sc->value);
3624                }
3625                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3626                     if(!is_pair(cdr(sc->code))) {
3627                          Error_0(sc,"syntax error in cond");
3628                     }
3629                     gc_disable(sc, 4);
3630                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3631                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3632                     gc_enable(sc);
3633                     s_goto(sc,OP_EVAL);
3634                }
3635                s_goto(sc,OP_BEGIN);
3636           } else {
3637                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3638                     s_return(sc,sc->NIL);
3639                } else {
3640                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3641                     sc->code = caar(sc->code);
3642                     s_clear_flag(sc, TAIL_CONTEXT);
3643                     s_goto(sc,OP_EVAL);
3644                }
3645           }
3646
3647      CASE(OP_DELAY):      /* delay */
3648           gc_disable(sc, 2);
3649           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3650           typeflag(x)=T_PROMISE;
3651           s_return_enable_gc(sc,x);
3652
3653      CASE(OP_AND0):       /* and */
3654           if (sc->code == sc->NIL) {
3655                s_return(sc,sc->T);
3656           }
3657           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3658           if (cdr(sc->code) != sc->NIL)
3659                s_clear_flag(sc, TAIL_CONTEXT);
3660           sc->code = car(sc->code);
3661           s_goto(sc,OP_EVAL);
3662
3663      CASE(OP_AND1):       /* and */
3664           if (is_false(sc->value)) {
3665                s_return(sc,sc->value);
3666           } else if (sc->code == sc->NIL) {
3667                s_return(sc,sc->value);
3668           } else {
3669                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3670                if (cdr(sc->code) != sc->NIL)
3671                     s_clear_flag(sc, TAIL_CONTEXT);
3672                sc->code = car(sc->code);
3673                s_goto(sc,OP_EVAL);
3674           }
3675
3676      CASE(OP_OR0):        /* or */
3677           if (sc->code == sc->NIL) {
3678                s_return(sc,sc->F);
3679           }
3680           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3681           if (cdr(sc->code) != sc->NIL)
3682                s_clear_flag(sc, TAIL_CONTEXT);
3683           sc->code = car(sc->code);
3684           s_goto(sc,OP_EVAL);
3685
3686      CASE(OP_OR1):        /* or */
3687           if (is_true(sc->value)) {
3688                s_return(sc,sc->value);
3689           } else if (sc->code == sc->NIL) {
3690                s_return(sc,sc->value);
3691           } else {
3692                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3693                if (cdr(sc->code) != sc->NIL)
3694                     s_clear_flag(sc, TAIL_CONTEXT);
3695                sc->code = car(sc->code);
3696                s_goto(sc,OP_EVAL);
3697           }
3698
3699      CASE(OP_C0STREAM):   /* cons-stream */
3700           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3701           sc->code = car(sc->code);
3702           s_goto(sc,OP_EVAL);
3703
3704      CASE(OP_C1STREAM):   /* cons-stream */
3705           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3706           gc_disable(sc, 3);
3707           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3708           typeflag(x)=T_PROMISE;
3709           s_return_enable_gc(sc, cons(sc, sc->args, x));
3710
3711      CASE(OP_MACRO0):     /* macro */
3712           if (is_pair(car(sc->code))) {
3713                x = caar(sc->code);
3714                gc_disable(sc, 2);
3715                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3716                gc_enable(sc);
3717           } else {
3718                x = car(sc->code);
3719                sc->code = cadr(sc->code);
3720           }
3721           if (!is_symbol(x)) {
3722                Error_0(sc,"variable is not a symbol");
3723           }
3724           s_save(sc,OP_MACRO1, sc->NIL, x);
3725           s_goto(sc,OP_EVAL);
3726
3727      CASE(OP_MACRO1):     /* macro */
3728           typeflag(sc->value) = T_MACRO;
3729           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3730           if (x != sc->NIL) {
3731                set_slot_in_env(sc, x, sc->value);
3732           } else {
3733                new_slot_in_env(sc, sc->code, sc->value);
3734           }
3735           s_return(sc,sc->code);
3736
3737      CASE(OP_CASE0):      /* case */
3738           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3739           sc->code = car(sc->code);
3740           s_clear_flag(sc, TAIL_CONTEXT);
3741           s_goto(sc,OP_EVAL);
3742
3743      CASE(OP_CASE1):      /* case */
3744           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3745                if (!is_pair(y = caar(x))) {
3746                     break;
3747                }
3748                for ( ; y != sc->NIL; y = cdr(y)) {
3749                     if (eqv(car(y), sc->value)) {
3750                          break;
3751                     }
3752                }
3753                if (y != sc->NIL) {
3754                     break;
3755                }
3756           }
3757           if (x != sc->NIL) {
3758                if (is_pair(caar(x))) {
3759                     sc->code = cdar(x);
3760                     s_goto(sc,OP_BEGIN);
3761                } else {/* else */
3762                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3763                     sc->code = caar(x);
3764                     s_goto(sc,OP_EVAL);
3765                }
3766           } else {
3767                s_return(sc,sc->NIL);
3768           }
3769
3770      CASE(OP_CASE2):      /* case */
3771           if (is_true(sc->value)) {
3772                s_goto(sc,OP_BEGIN);
3773           } else {
3774                s_return(sc,sc->NIL);
3775           }
3776
3777      CASE(OP_PAPPLY):     /* apply */
3778           sc->code = car(sc->args);
3779           sc->args = list_star(sc,cdr(sc->args));
3780           /*sc->args = cadr(sc->args);*/
3781           s_goto(sc,OP_APPLY);
3782
3783      CASE(OP_PEVAL): /* eval */
3784           if(cdr(sc->args)!=sc->NIL) {
3785                sc->envir=cadr(sc->args);
3786           }
3787           sc->code = car(sc->args);
3788           s_goto(sc,OP_EVAL);
3789
3790      CASE(OP_CONTINUATION):    /* call-with-current-continuation */
3791           sc->code = car(sc->args);
3792           gc_disable(sc, 2);
3793           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3794           gc_enable(sc);
3795           s_goto(sc,OP_APPLY);
3796
3797      default:
3798           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3799           Error_0(sc,sc->strbuff);
3800      }
3801      return sc->T;
3802 }
3803
3804 #if USE_PLIST
3805 static pointer
3806 get_property(scheme *sc, pointer obj, pointer key)
3807 {
3808   pointer x;
3809
3810   assert (is_symbol(obj));
3811   assert (is_symbol(key));
3812
3813   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3814     if (caar(x) == key)
3815       break;
3816   }
3817
3818   if (x != sc->NIL)
3819     return cdar(x);
3820
3821   return sc->NIL;
3822 }
3823
3824 static pointer
3825 set_property(scheme *sc, pointer obj, pointer key, pointer value)
3826 {
3827 #define set_property_allocates  2
3828   pointer x;
3829
3830   assert (is_symbol(obj));
3831   assert (is_symbol(key));
3832
3833   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3834     if (caar(x) == key)
3835       break;
3836   }
3837
3838   if (x != sc->NIL)
3839     cdar(x) = value;
3840   else {
3841     gc_disable(sc, gc_reservations(set_property));
3842     symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
3843     gc_enable(sc);
3844   }
3845
3846   return sc->T;
3847 }
3848 #endif
3849
3850 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3851      pointer x;
3852      num v;
3853 #if USE_MATH
3854      double dd;
3855 #endif
3856
3857      switch (op) {
3858 #if USE_MATH
3859      CASE(OP_INEX2EX):    /* inexact->exact */
3860           x=car(sc->args);
3861           if(num_is_integer(x)) {
3862                s_return(sc,x);
3863           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3864                s_return(sc,mk_integer(sc,ivalue(x)));
3865           } else {
3866                Error_1(sc,"inexact->exact: not integral:",x);
3867           }
3868
3869      CASE(OP_EXP):
3870           x=car(sc->args);
3871           s_return(sc, mk_real(sc, exp(rvalue(x))));
3872
3873      CASE(OP_LOG):
3874           x=car(sc->args);
3875           s_return(sc, mk_real(sc, log(rvalue(x))));
3876
3877      CASE(OP_SIN):
3878           x=car(sc->args);
3879           s_return(sc, mk_real(sc, sin(rvalue(x))));
3880
3881      CASE(OP_COS):
3882           x=car(sc->args);
3883           s_return(sc, mk_real(sc, cos(rvalue(x))));
3884
3885      CASE(OP_TAN):
3886           x=car(sc->args);
3887           s_return(sc, mk_real(sc, tan(rvalue(x))));
3888
3889      CASE(OP_ASIN):
3890           x=car(sc->args);
3891           s_return(sc, mk_real(sc, asin(rvalue(x))));
3892
3893      CASE(OP_ACOS):
3894           x=car(sc->args);
3895           s_return(sc, mk_real(sc, acos(rvalue(x))));
3896
3897      CASE(OP_ATAN):
3898           x=car(sc->args);
3899           if(cdr(sc->args)==sc->NIL) {
3900                s_return(sc, mk_real(sc, atan(rvalue(x))));
3901           } else {
3902                pointer y=cadr(sc->args);
3903                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3904           }
3905
3906      CASE(OP_SQRT):
3907           x=car(sc->args);
3908           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3909
3910      CASE(OP_EXPT): {
3911           double result;
3912           int real_result=1;
3913           pointer y=cadr(sc->args);
3914           x=car(sc->args);
3915           if (num_is_integer(x) && num_is_integer(y))
3916              real_result=0;
3917           /* This 'if' is an R5RS compatibility fix. */
3918           /* NOTE: Remove this 'if' fix for R6RS.    */
3919           if (rvalue(x) == 0 && rvalue(y) < 0) {
3920              result = 0.0;
3921           } else {
3922              result = pow(rvalue(x),rvalue(y));
3923           }
3924           /* Before returning integer result make sure we can. */
3925           /* If the test fails, result is too big for integer. */
3926           if (!real_result)
3927           {
3928             long result_as_long = (long)result;
3929             if (result != (double)result_as_long)
3930               real_result = 1;
3931           }
3932           if (real_result) {
3933              s_return(sc, mk_real(sc, result));
3934           } else {
3935              s_return(sc, mk_integer(sc, result));
3936           }
3937      }
3938
3939      CASE(OP_FLOOR):
3940           x=car(sc->args);
3941           s_return(sc, mk_real(sc, floor(rvalue(x))));
3942
3943      CASE(OP_CEILING):
3944           x=car(sc->args);
3945           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3946
3947      CASE(OP_TRUNCATE ): {
3948           double rvalue_of_x ;
3949           x=car(sc->args);
3950           rvalue_of_x = rvalue(x) ;
3951           if (rvalue_of_x > 0) {
3952             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3953           } else {
3954             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3955           }
3956      }
3957
3958      CASE(OP_ROUND):
3959         x=car(sc->args);
3960         if (num_is_integer(x))
3961             s_return(sc, x);
3962         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3963 #endif
3964
3965      CASE(OP_ADD):        /* + */
3966        v=num_zero;
3967        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3968          v=num_add(v,nvalue(car(x)));
3969        }
3970        gc_disable(sc, 1);
3971        s_return_enable_gc(sc, mk_number(sc, v));
3972
3973      CASE(OP_MUL):        /* * */
3974        v=num_one;
3975        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3976          v=num_mul(v,nvalue(car(x)));
3977        }
3978        gc_disable(sc, 1);
3979        s_return_enable_gc(sc, mk_number(sc, v));
3980
3981      CASE(OP_SUB):        /* - */
3982        if(cdr(sc->args)==sc->NIL) {
3983          x=sc->args;
3984          v=num_zero;
3985        } else {
3986          x = cdr(sc->args);
3987          v = nvalue(car(sc->args));
3988        }
3989        for (; x != sc->NIL; x = cdr(x)) {
3990          v=num_sub(v,nvalue(car(x)));
3991        }
3992        gc_disable(sc, 1);
3993        s_return_enable_gc(sc, mk_number(sc, v));
3994
3995      CASE(OP_DIV):        /* / */
3996        if(cdr(sc->args)==sc->NIL) {
3997          x=sc->args;
3998          v=num_one;
3999        } else {
4000          x = cdr(sc->args);
4001          v = nvalue(car(sc->args));
4002        }
4003        for (; x != sc->NIL; x = cdr(x)) {
4004          if (!is_zero_double(rvalue(car(x))))
4005            v=num_div(v,nvalue(car(x)));
4006          else {
4007            Error_0(sc,"/: division by zero");
4008          }
4009        }
4010        gc_disable(sc, 1);
4011        s_return_enable_gc(sc, mk_number(sc, v));
4012
4013      CASE(OP_INTDIV):        /* quotient */
4014           if(cdr(sc->args)==sc->NIL) {
4015                x=sc->args;
4016                v=num_one;
4017           } else {
4018                x = cdr(sc->args);
4019                v = nvalue(car(sc->args));
4020           }
4021           for (; x != sc->NIL; x = cdr(x)) {
4022                if (ivalue(car(x)) != 0)
4023                     v=num_intdiv(v,nvalue(car(x)));
4024                else {
4025                     Error_0(sc,"quotient: division by zero");
4026                }
4027           }
4028           gc_disable(sc, 1);
4029           s_return_enable_gc(sc, mk_number(sc, v));
4030
4031      CASE(OP_REM):        /* remainder */
4032           v = nvalue(car(sc->args));
4033           if (ivalue(cadr(sc->args)) != 0)
4034                v=num_rem(v,nvalue(cadr(sc->args)));
4035           else {
4036                Error_0(sc,"remainder: division by zero");
4037           }
4038           gc_disable(sc, 1);
4039           s_return_enable_gc(sc, mk_number(sc, v));
4040
4041      CASE(OP_MOD):        /* modulo */
4042           v = nvalue(car(sc->args));
4043           if (ivalue(cadr(sc->args)) != 0)
4044                v=num_mod(v,nvalue(cadr(sc->args)));
4045           else {
4046                Error_0(sc,"modulo: division by zero");
4047           }
4048           gc_disable(sc, 1);
4049           s_return_enable_gc(sc, mk_number(sc, v));
4050
4051      CASE(OP_CAR):        /* car */
4052           s_return(sc,caar(sc->args));
4053
4054      CASE(OP_CDR):        /* cdr */
4055           s_return(sc,cdar(sc->args));
4056
4057      CASE(OP_CONS):       /* cons */
4058           cdr(sc->args) = cadr(sc->args);
4059           s_return(sc,sc->args);
4060
4061      CASE(OP_SETCAR):     /* set-car! */
4062        if(!is_immutable(car(sc->args))) {
4063          caar(sc->args) = cadr(sc->args);
4064          s_return(sc,car(sc->args));
4065        } else {
4066          Error_0(sc,"set-car!: unable to alter immutable pair");
4067        }
4068
4069      CASE(OP_SETCDR):     /* set-cdr! */
4070        if(!is_immutable(car(sc->args))) {
4071          cdar(sc->args) = cadr(sc->args);
4072          s_return(sc,car(sc->args));
4073        } else {
4074          Error_0(sc,"set-cdr!: unable to alter immutable pair");
4075        }
4076
4077      CASE(OP_CHAR2INT): { /* char->integer */
4078           char c;
4079           c=(char)ivalue(car(sc->args));
4080           gc_disable(sc, 1);
4081           s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
4082      }
4083
4084      CASE(OP_INT2CHAR): { /* integer->char */
4085           unsigned char c;
4086           c=(unsigned char)ivalue(car(sc->args));
4087           gc_disable(sc, 1);
4088           s_return_enable_gc(sc, mk_character(sc, (char) c));
4089      }
4090
4091      CASE(OP_CHARUPCASE): {
4092           unsigned char c;
4093           c=(unsigned char)ivalue(car(sc->args));
4094           c=toupper(c);
4095           gc_disable(sc, 1);
4096           s_return_enable_gc(sc, mk_character(sc, (char) c));
4097      }
4098
4099      CASE(OP_CHARDNCASE): {
4100           unsigned char c;
4101           c=(unsigned char)ivalue(car(sc->args));
4102           c=tolower(c);
4103           gc_disable(sc, 1);
4104           s_return_enable_gc(sc, mk_character(sc, (char) c));
4105      }
4106
4107      CASE(OP_STR2SYM):  /* string->symbol */
4108           gc_disable(sc, gc_reservations (mk_symbol));
4109           s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
4110
4111      CASE(OP_STR2ATOM): /* string->atom */ {
4112           char *s=strvalue(car(sc->args));
4113           long pf = 0;
4114           if(cdr(sc->args)!=sc->NIL) {
4115             /* we know cadr(sc->args) is a natural number */
4116             /* see if it is 2, 8, 10, or 16, or error */
4117             pf = ivalue_unchecked(cadr(sc->args));
4118             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
4119                /* base is OK */
4120             }
4121             else {
4122               pf = -1;
4123             }
4124           }
4125           if (pf < 0) {
4126             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
4127           } else if(*s=='#') /* no use of base! */ {
4128             s_return(sc, mk_sharp_const(sc, s+1));
4129           } else {
4130             if (pf == 0 || pf == 10) {
4131               s_return(sc, mk_atom(sc, s));
4132             }
4133             else {
4134               char *ep;
4135               long iv = strtol(s,&ep,(int )pf);
4136               if (*ep == 0) {
4137                 s_return(sc, mk_integer(sc, iv));
4138               }
4139               else {
4140                 s_return(sc, sc->F);
4141               }
4142             }
4143           }
4144         }
4145
4146      CASE(OP_SYM2STR): /* symbol->string */
4147           gc_disable(sc, 1);
4148           x=mk_string(sc,symname(car(sc->args)));
4149           setimmutable(x);
4150           s_return_enable_gc(sc, x);
4151
4152      CASE(OP_ATOM2STR): /* atom->string */ {
4153           long pf = 0;
4154           x=car(sc->args);
4155           if(cdr(sc->args)!=sc->NIL) {
4156             /* we know cadr(sc->args) is a natural number */
4157             /* see if it is 2, 8, 10, or 16, or error */
4158             pf = ivalue_unchecked(cadr(sc->args));
4159             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
4160               /* base is OK */
4161             }
4162             else {
4163               pf = -1;
4164             }
4165           }
4166           if (pf < 0) {
4167             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
4168           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
4169             char *p;
4170             int len;
4171             atom2str(sc,x,(int )pf,&p,&len);
4172             gc_disable(sc, 1);
4173             s_return_enable_gc(sc, mk_counted_string(sc, p, len));
4174           } else {
4175             Error_1(sc, "atom->string: not an atom:", x);
4176           }
4177         }
4178
4179      CASE(OP_MKSTRING): { /* make-string */
4180           int fill=' ';
4181           int len;
4182
4183           len=ivalue(car(sc->args));
4184
4185           if(cdr(sc->args)!=sc->NIL) {
4186                fill=charvalue(cadr(sc->args));
4187           }
4188           gc_disable(sc, 1);
4189           s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
4190      }
4191
4192      CASE(OP_STRLEN):  /* string-length */
4193           gc_disable(sc, 1);
4194           s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
4195
4196      CASE(OP_STRREF): { /* string-ref */
4197           char *str;
4198           int index;
4199
4200           str=strvalue(car(sc->args));
4201
4202           index=ivalue(cadr(sc->args));
4203
4204           if(index>=strlength(car(sc->args))) {
4205                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
4206           }
4207
4208           gc_disable(sc, 1);
4209           s_return_enable_gc(sc,
4210                              mk_character(sc, ((unsigned char*) str)[index]));
4211      }
4212
4213      CASE(OP_STRSET): { /* string-set! */
4214           char *str;
4215           int index;
4216           int c;
4217
4218           if(is_immutable(car(sc->args))) {
4219                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
4220           }
4221           str=strvalue(car(sc->args));
4222
4223           index=ivalue(cadr(sc->args));
4224           if(index>=strlength(car(sc->args))) {
4225                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
4226           }
4227
4228           c=charvalue(caddr(sc->args));
4229
4230           str[index]=(char)c;
4231           s_return(sc,car(sc->args));
4232      }
4233
4234      CASE(OP_STRAPPEND): { /* string-append */
4235        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4236        int len = 0;
4237        pointer newstr;
4238        char *pos;
4239
4240        /* compute needed length for new string */
4241        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4242           len += strlength(car(x));
4243        }
4244        gc_disable(sc, 1);
4245        newstr = mk_empty_string(sc, len, ' ');
4246        /* store the contents of the argument strings into the new string */
4247        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
4248            pos += strlength(car(x)), x = cdr(x)) {
4249            memcpy(pos, strvalue(car(x)), strlength(car(x)));
4250        }
4251        s_return_enable_gc(sc, newstr);
4252      }
4253
4254      CASE(OP_SUBSTR): { /* substring */
4255           char *str;
4256           int index0;
4257           int index1;
4258           int len;
4259
4260           str=strvalue(car(sc->args));
4261
4262           index0=ivalue(cadr(sc->args));
4263
4264           if(index0>strlength(car(sc->args))) {
4265                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
4266           }
4267
4268           if(cddr(sc->args)!=sc->NIL) {
4269                index1=ivalue(caddr(sc->args));
4270                if(index1>strlength(car(sc->args)) || index1<index0) {
4271                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
4272                }
4273           } else {
4274                index1=strlength(car(sc->args));
4275           }
4276
4277           len=index1-index0;
4278           gc_disable(sc, 1);
4279           x=mk_empty_string(sc,len,' ');
4280           memcpy(strvalue(x),str+index0,len);
4281           strvalue(x)[len]=0;
4282
4283           s_return_enable_gc(sc, x);
4284      }
4285
4286      CASE(OP_VECTOR): {   /* vector */
4287           int i;
4288           pointer vec;
4289           int len=list_length(sc,sc->args);
4290           if(len<0) {
4291                Error_1(sc,"vector: not a proper list:",sc->args);
4292           }
4293           vec=mk_vector(sc,len);
4294           if(sc->no_memory) { s_return(sc, sc->sink); }
4295           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
4296                set_vector_elem(vec,i,car(x));
4297           }
4298           s_return(sc,vec);
4299      }
4300
4301      CASE(OP_MKVECTOR): { /* make-vector */
4302           pointer fill=sc->NIL;
4303           int len;
4304           pointer vec;
4305
4306           len=ivalue(car(sc->args));
4307
4308           if(cdr(sc->args)!=sc->NIL) {
4309                fill=cadr(sc->args);
4310           }
4311           vec=mk_vector(sc,len);
4312           if(sc->no_memory) { s_return(sc, sc->sink); }
4313           if(fill!=sc->NIL) {
4314                fill_vector(vec,fill);
4315           }
4316           s_return(sc,vec);
4317      }
4318
4319      CASE(OP_VECLEN):  /* vector-length */
4320           gc_disable(sc, 1);
4321           s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
4322
4323      CASE(OP_VECREF): { /* vector-ref */
4324           int index;
4325
4326           index=ivalue(cadr(sc->args));
4327
4328           if(index>=ivalue(car(sc->args))) {
4329                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
4330           }
4331
4332           s_return(sc,vector_elem(car(sc->args),index));
4333      }
4334
4335      CASE(OP_VECSET): {   /* vector-set! */
4336           int index;
4337
4338           if(is_immutable(car(sc->args))) {
4339                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
4340           }
4341
4342           index=ivalue(cadr(sc->args));
4343           if(index>=ivalue(car(sc->args))) {
4344                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
4345           }
4346
4347           set_vector_elem(car(sc->args),index,caddr(sc->args));
4348           s_return(sc,car(sc->args));
4349      }
4350
4351      default:
4352           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4353           Error_0(sc,sc->strbuff);
4354      }
4355      return sc->T;
4356 }
4357
4358 static int is_list(scheme *sc, pointer a)
4359 { return list_length(sc,a) >= 0; }
4360
4361 /* Result is:
4362    proper list: length
4363    circular list: -1
4364    not even a pair: -2
4365    dotted list: -2 minus length before dot
4366 */
4367 int list_length(scheme *sc, pointer a) {
4368     int i=0;
4369     pointer slow, fast;
4370
4371     slow = fast = a;
4372     while (1)
4373     {
4374         if (fast == sc->NIL)
4375                 return i;
4376         if (!is_pair(fast))
4377                 return -2 - i;
4378         fast = cdr(fast);
4379         ++i;
4380         if (fast == sc->NIL)
4381                 return i;
4382         if (!is_pair(fast))
4383                 return -2 - i;
4384         ++i;
4385         fast = cdr(fast);
4386
4387         /* Safe because we would have already returned if `fast'
4388            encountered a non-pair. */
4389         slow = cdr(slow);
4390         if (fast == slow)
4391         {
4392             /* the fast pointer has looped back around and caught up
4393                with the slow pointer, hence the structure is circular,
4394                not of finite length, and therefore not a list */
4395             return -1;
4396         }
4397     }
4398 }
4399
4400 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
4401      pointer x;
4402      num v;
4403      int (*comp_func)(num,num)=0;
4404
4405      switch (op) {
4406      CASE(OP_NOT):        /* not */
4407           s_retbool(is_false(car(sc->args)));
4408      CASE(OP_BOOLP):       /* boolean? */
4409           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
4410      CASE(OP_EOFOBJP):       /* boolean? */
4411           s_retbool(car(sc->args) == sc->EOF_OBJ);
4412      CASE(OP_NULLP):       /* null? */
4413           s_retbool(car(sc->args) == sc->NIL);
4414      CASE(OP_NUMEQ):      /* = */
4415      CASE(OP_LESS):       /* < */
4416      CASE(OP_GRE):        /* > */
4417      CASE(OP_LEQ):        /* <= */
4418      CASE(OP_GEQ):        /* >= */
4419           switch(op) {
4420                case OP_NUMEQ: comp_func=num_eq; break;
4421                case OP_LESS:  comp_func=num_lt; break;
4422                case OP_GRE:   comp_func=num_gt; break;
4423                case OP_LEQ:   comp_func=num_le; break;
4424                case OP_GEQ:   comp_func=num_ge; break;
4425                default: assert (! "reached");
4426           }
4427           x=sc->args;
4428           v=nvalue(car(x));
4429           x=cdr(x);
4430
4431           for (; x != sc->NIL; x = cdr(x)) {
4432                if(!comp_func(v,nvalue(car(x)))) {
4433                     s_retbool(0);
4434                }
4435            v=nvalue(car(x));
4436           }
4437           s_retbool(1);
4438      CASE(OP_SYMBOLP):     /* symbol? */
4439           s_retbool(is_symbol(car(sc->args)));
4440      CASE(OP_NUMBERP):     /* number? */
4441           s_retbool(is_number(car(sc->args)));
4442      CASE(OP_STRINGP):     /* string? */
4443           s_retbool(is_string(car(sc->args)));
4444      CASE(OP_INTEGERP):     /* integer? */
4445           s_retbool(is_integer(car(sc->args)));
4446      CASE(OP_REALP):     /* real? */
4447           s_retbool(is_number(car(sc->args))); /* All numbers are real */
4448      CASE(OP_CHARP):     /* char? */
4449           s_retbool(is_character(car(sc->args)));
4450 #if USE_CHAR_CLASSIFIERS
4451      CASE(OP_CHARAP):     /* char-alphabetic? */
4452           s_retbool(Cisalpha(ivalue(car(sc->args))));
4453      CASE(OP_CHARNP):     /* char-numeric? */
4454           s_retbool(Cisdigit(ivalue(car(sc->args))));
4455      CASE(OP_CHARWP):     /* char-whitespace? */
4456           s_retbool(Cisspace(ivalue(car(sc->args))));
4457      CASE(OP_CHARUP):     /* char-upper-case? */
4458           s_retbool(Cisupper(ivalue(car(sc->args))));
4459      CASE(OP_CHARLP):     /* char-lower-case? */
4460           s_retbool(Cislower(ivalue(car(sc->args))));
4461 #endif
4462      CASE(OP_PORTP):     /* port? */
4463           s_retbool(is_port(car(sc->args)));
4464      CASE(OP_INPORTP):     /* input-port? */
4465           s_retbool(is_inport(car(sc->args)));
4466      CASE(OP_OUTPORTP):     /* output-port? */
4467           s_retbool(is_outport(car(sc->args)));
4468      CASE(OP_PROCP):       /* procedure? */
4469           /*--
4470               * continuation should be procedure by the example
4471               * (call-with-current-continuation procedure?) ==> #t
4472                  * in R^3 report sec. 6.9
4473               */
4474           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
4475                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
4476      CASE(OP_PAIRP):       /* pair? */
4477           s_retbool(is_pair(car(sc->args)));
4478      CASE(OP_LISTP):       /* list? */
4479        s_retbool(list_length(sc,car(sc->args)) >= 0);
4480
4481      CASE(OP_ENVP):        /* environment? */
4482           s_retbool(is_environment(car(sc->args)));
4483      CASE(OP_VECTORP):     /* vector? */
4484           s_retbool(is_vector(car(sc->args)));
4485      CASE(OP_EQ):         /* eq? */
4486           s_retbool(car(sc->args) == cadr(sc->args));
4487      CASE(OP_EQV):        /* eqv? */
4488           s_retbool(eqv(car(sc->args), cadr(sc->args)));
4489      default:
4490           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4491           Error_0(sc,sc->strbuff);
4492      }
4493      return sc->T;
4494 }
4495
4496 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
4497      pointer x, y;
4498
4499      switch (op) {
4500      CASE(OP_FORCE):      /* force */
4501           sc->code = car(sc->args);
4502           if (is_promise(sc->code)) {
4503                /* Should change type to closure here */
4504                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
4505                sc->args = sc->NIL;
4506                s_goto(sc,OP_APPLY);
4507           } else {
4508                s_return(sc,sc->code);
4509           }
4510
4511      CASE(OP_SAVE_FORCED):     /* Save forced value replacing promise */
4512           memcpy(sc->code,sc->value,sizeof(struct cell));
4513           s_return(sc,sc->value);
4514
4515      CASE(OP_WRITE):      /* write */
4516      CASE(OP_DISPLAY):    /* display */
4517      CASE(OP_WRITE_CHAR): /* write-char */
4518           if(is_pair(cdr(sc->args))) {
4519                if(cadr(sc->args)!=sc->outport) {
4520                     x=cons(sc,sc->outport,sc->NIL);
4521                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4522                     sc->outport=cadr(sc->args);
4523                }
4524           }
4525           sc->args = car(sc->args);
4526           if(op==OP_WRITE) {
4527                sc->print_flag = 1;
4528           } else {
4529                sc->print_flag = 0;
4530           }
4531           s_goto(sc,OP_P0LIST);
4532
4533      CASE(OP_NEWLINE):    /* newline */
4534           if(is_pair(sc->args)) {
4535                if(car(sc->args)!=sc->outport) {
4536                     x=cons(sc,sc->outport,sc->NIL);
4537                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4538                     sc->outport=car(sc->args);
4539                }
4540           }
4541           putstr(sc, "\n");
4542           s_return(sc,sc->T);
4543
4544      CASE(OP_ERR0):  /* error */
4545           sc->retcode=-1;
4546           if (!is_string(car(sc->args))) {
4547                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
4548                setimmutable(car(sc->args));
4549           }
4550           putstr(sc, "Error: ");
4551           putstr(sc, strvalue(car(sc->args)));
4552           sc->args = cdr(sc->args);
4553           s_thread_to(sc,OP_ERR1);
4554
4555      CASE(OP_ERR1):  /* error */
4556           putstr(sc, " ");
4557           if (sc->args != sc->NIL) {
4558                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
4559                sc->args = car(sc->args);
4560                sc->print_flag = 1;
4561                s_goto(sc,OP_P0LIST);
4562           } else {
4563                putstr(sc, "\n");
4564                if(sc->interactive_repl) {
4565                     s_goto(sc,OP_T0LVL);
4566                } else {
4567                     return sc->NIL;
4568                }
4569           }
4570
4571      CASE(OP_REVERSE):   /* reverse */
4572           s_return(sc,reverse(sc, sc->NIL, car(sc->args)));
4573
4574      CASE(OP_LIST_STAR): /* list* */
4575           s_return(sc,list_star(sc,sc->args));
4576
4577      CASE(OP_APPEND):    /* append */
4578           x = sc->NIL;
4579           y = sc->args;
4580           if (y == x) {
4581               s_return(sc, x);
4582           }
4583
4584           /* cdr() in the while condition is not a typo. If car() */
4585           /* is used (append '() 'a) will return the wrong result.*/
4586           while (cdr(y) != sc->NIL) {
4587               x = revappend(sc, x, car(y));
4588               y = cdr(y);
4589               if (x == sc->F) {
4590                   Error_0(sc, "non-list argument to append");
4591               }
4592           }
4593
4594           s_return(sc, reverse_in_place(sc, car(y), x));
4595
4596 #if USE_PLIST
4597      CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
4598           gc_disable(sc, gc_reservations(set_property));
4599           s_return_enable_gc(sc,
4600                              set_property(sc, car(sc->args),
4601                                           cadr(sc->args), caddr(sc->args)));
4602
4603      CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
4604           s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
4605 #endif /* USE_PLIST */
4606
4607 #if USE_TAGS
4608      CASE(OP_TAG_VALUE): {      /* not exposed */
4609           /* This tags sc->value with car(sc->args).  Useful to tag
4610            * results of opcode evaluations.  */
4611           pointer a, b, c;
4612           free_cons(sc, sc->args, &a, &b);
4613           free_cons(sc, b, &b, &c);
4614           assert(c == sc->NIL);
4615           s_return(sc, mk_tagged_value(sc, sc->value, a, b));
4616         }
4617
4618      CASE(OP_MK_TAGGED):        /* make-tagged-value */
4619           if (is_vector(car(sc->args)))
4620                Error_0(sc, "cannot tag vector");
4621           s_return(sc, mk_tagged_value(sc, car(sc->args),
4622                                        car(cadr(sc->args)),
4623                                        cdr(cadr(sc->args))));
4624
4625      CASE(OP_GET_TAG):        /* get-tag */
4626           s_return(sc, get_tag(sc, car(sc->args)));
4627 #endif /* USE_TAGS */
4628
4629      CASE(OP_QUIT):       /* quit */
4630           if(is_pair(sc->args)) {
4631                sc->retcode=ivalue(car(sc->args));
4632           }
4633           return (sc->NIL);
4634
4635      CASE(OP_GC):         /* gc */
4636           gc(sc, sc->NIL, sc->NIL);
4637           s_return(sc,sc->T);
4638
4639      CASE(OP_GCVERB):          /* gc-verbose */
4640      {    int  was = sc->gc_verbose;
4641
4642           sc->gc_verbose = (car(sc->args) != sc->F);
4643           s_retbool(was);
4644      }
4645
4646      CASE(OP_NEWSEGMENT): /* new-segment */
4647           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
4648                Error_0(sc,"new-segment: argument must be a number");
4649           }
4650           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
4651           s_return(sc,sc->T);
4652
4653      CASE(OP_OBLIST): /* oblist */
4654           s_return(sc, oblist_all_symbols(sc));
4655
4656      CASE(OP_CURR_INPORT): /* current-input-port */
4657           s_return(sc,sc->inport);
4658
4659      CASE(OP_CURR_OUTPORT): /* current-output-port */
4660           s_return(sc,sc->outport);
4661
4662      CASE(OP_OPEN_INFILE): /* open-input-file */
4663      CASE(OP_OPEN_OUTFILE): /* open-output-file */
4664      CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
4665           int prop=0;
4666           pointer p;
4667           switch(op) {
4668                case OP_OPEN_INFILE:     prop=port_input; break;
4669                case OP_OPEN_OUTFILE:    prop=port_output; break;
4670                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
4671                default: assert (! "reached");
4672           }
4673           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
4674           if(p==sc->NIL) {
4675                s_return(sc,sc->F);
4676           }
4677           s_return(sc,p);
4678           break;
4679      default: assert (! "reached");
4680      }
4681
4682 #if USE_STRING_PORTS
4683      CASE(OP_OPEN_INSTRING): /* open-input-string */
4684      CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ {
4685           int prop=0;
4686           pointer p;
4687           switch(op) {
4688                case OP_OPEN_INSTRING:     prop=port_input; break;
4689                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
4690                default: assert (! "reached");
4691           }
4692           p=port_from_string(sc, strvalue(car(sc->args)),
4693                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
4694           if(p==sc->NIL) {
4695                s_return(sc,sc->F);
4696           }
4697           s_return(sc,p);
4698      }
4699      CASE(OP_OPEN_OUTSTRING): /* open-output-string */ {
4700           pointer p;
4701           if(car(sc->args)==sc->NIL) {
4702                p=port_from_scratch(sc);
4703                if(p==sc->NIL) {
4704                     s_return(sc,sc->F);
4705                }
4706           } else {
4707                p=port_from_string(sc, strvalue(car(sc->args)),
4708                       strvalue(car(sc->args))+strlength(car(sc->args)),
4709                           port_output);
4710                if(p==sc->NIL) {
4711                     s_return(sc,sc->F);
4712                }
4713           }
4714           s_return(sc,p);
4715      }
4716      CASE(OP_GET_OUTSTRING): /* get-output-string */ {
4717           port *p;
4718
4719           if ((p=car(sc->args)->_object._port)->kind&port_string) {
4720                off_t size;
4721                char *str;
4722
4723                size=p->rep.string.curr-p->rep.string.start+1;
4724                str=sc->malloc(size);
4725                if(str != NULL) {
4726                     pointer s;
4727
4728                     memcpy(str,p->rep.string.start,size-1);
4729                     str[size-1]='\0';
4730                     s=mk_string(sc,str);
4731                     sc->free(str);
4732                     s_return(sc,s);
4733                }
4734           }
4735           s_return(sc,sc->F);
4736      }
4737 #endif
4738
4739      CASE(OP_CLOSE_INPORT): /* close-input-port */
4740           port_close(sc,car(sc->args),port_input);
4741           s_return(sc,sc->T);
4742
4743      CASE(OP_CLOSE_OUTPORT): /* close-output-port */
4744           port_close(sc,car(sc->args),port_output);
4745           s_return(sc,sc->T);
4746
4747      CASE(OP_INT_ENV): /* interaction-environment */
4748           s_return(sc,sc->global_env);
4749
4750      CASE(OP_CURR_ENV): /* current-environment */
4751           s_return(sc,sc->envir);
4752
4753      }
4754      return sc->T;
4755 }
4756
4757 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
4758      pointer x;
4759
4760      if(sc->nesting!=0) {
4761           int n=sc->nesting;
4762           sc->nesting=0;
4763           sc->retcode=-1;
4764           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
4765      }
4766
4767      switch (op) {
4768      /* ========== reading part ========== */
4769      CASE(OP_READ):
4770           if(!is_pair(sc->args)) {
4771                s_goto(sc,OP_READ_INTERNAL);
4772           }
4773           if(!is_inport(car(sc->args))) {
4774                Error_1(sc,"read: not an input port:",car(sc->args));
4775           }
4776           if(car(sc->args)==sc->inport) {
4777                s_goto(sc,OP_READ_INTERNAL);
4778           }
4779           x=sc->inport;
4780           sc->inport=car(sc->args);
4781           x=cons(sc,x,sc->NIL);
4782           s_save(sc,OP_SET_INPORT, x, sc->NIL);
4783           s_goto(sc,OP_READ_INTERNAL);
4784
4785      CASE(OP_READ_CHAR): /* read-char */
4786      CASE(OP_PEEK_CHAR): /* peek-char */ {
4787           int c;
4788           if(is_pair(sc->args)) {
4789                if(car(sc->args)!=sc->inport) {
4790                     x=sc->inport;
4791                     x=cons(sc,x,sc->NIL);
4792                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
4793                     sc->inport=car(sc->args);
4794                }
4795           }
4796           c=inchar(sc);
4797           if(c==EOF) {
4798                s_return(sc,sc->EOF_OBJ);
4799           }
4800           if(sc->op==OP_PEEK_CHAR) {
4801                backchar(sc,c);
4802           }
4803           s_return(sc,mk_character(sc,c));
4804      }
4805
4806      CASE(OP_CHAR_READY): /* char-ready? */ {
4807           pointer p=sc->inport;
4808           int res;
4809           if(is_pair(sc->args)) {
4810                p=car(sc->args);
4811           }
4812           res=p->_object._port->kind&port_string;
4813           s_retbool(res);
4814      }
4815
4816      CASE(OP_SET_INPORT): /* set-input-port */
4817           sc->inport=car(sc->args);
4818           s_return(sc,sc->value);
4819
4820      CASE(OP_SET_OUTPORT): /* set-output-port */
4821           sc->outport=car(sc->args);
4822           s_return(sc,sc->value);
4823
4824      CASE(OP_RDSEXPR):
4825           switch (sc->tok) {
4826           case TOK_EOF:
4827                s_return(sc,sc->EOF_OBJ);
4828           /* NOTREACHED */
4829           case TOK_VEC:
4830                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
4831                /* fall through */
4832           case TOK_LPAREN:
4833                sc->tok = token(sc);
4834                if (sc->tok == TOK_RPAREN) {
4835                     s_return(sc,sc->NIL);
4836                } else if (sc->tok == TOK_DOT) {
4837                     Error_0(sc,"syntax error: illegal dot expression");
4838                } else {
4839                     sc->nesting_stack[sc->file_i]++;
4840 #if USE_TAGS && SHOW_ERROR_LINE
4841                     if (sc->load_stack[sc->file_i].kind & port_file) {
4842                       const char *filename =
4843                         sc->load_stack[sc->file_i].rep.stdio.filename;
4844                       int lineno =
4845                         sc->load_stack[sc->file_i].rep.stdio.curr_line;
4846
4847                       s_save(sc, OP_TAG_VALUE,
4848                              cons(sc, mk_string(sc, filename),
4849                                   cons(sc, mk_integer(sc, lineno), sc->NIL)),
4850                              sc->NIL);
4851                     }
4852 #endif
4853                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
4854                     s_thread_to(sc,OP_RDSEXPR);
4855                }
4856           case TOK_QUOTE:
4857                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
4858                sc->tok = token(sc);
4859                s_thread_to(sc,OP_RDSEXPR);
4860           case TOK_BQUOTE:
4861                sc->tok = token(sc);
4862                if(sc->tok==TOK_VEC) {
4863                  s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
4864                  sc->tok=TOK_LPAREN;
4865                  s_thread_to(sc,OP_RDSEXPR);
4866                } else {
4867                  s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
4868                }
4869                s_thread_to(sc,OP_RDSEXPR);
4870           case TOK_COMMA:
4871                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
4872                sc->tok = token(sc);
4873                s_thread_to(sc,OP_RDSEXPR);
4874           case TOK_ATMARK:
4875                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
4876                sc->tok = token(sc);
4877                s_thread_to(sc,OP_RDSEXPR);
4878           case TOK_ATOM:
4879                s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
4880           case TOK_DQUOTE:
4881                x=readstrexp(sc);
4882                if(x==sc->F) {
4883                  Error_0(sc,"Error reading string");
4884                }
4885                setimmutable(x);
4886                s_return(sc,x);
4887           case TOK_SHARP: {
4888                pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
4889                if(f==sc->NIL) {
4890                     Error_0(sc,"undefined sharp expression");
4891                } else {
4892                     sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
4893                     s_goto(sc,OP_EVAL);
4894                }
4895           }
4896           case TOK_SHARP_CONST:
4897                if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
4898                     Error_0(sc,"undefined sharp expression");
4899                } else {
4900                     s_return(sc,x);
4901                }
4902           default:
4903                Error_0(sc,"syntax error: illegal token");
4904           }
4905           break;
4906
4907      CASE(OP_RDLIST): {
4908           gc_disable(sc, 1);
4909           sc->args = cons(sc, sc->value, sc->args);
4910           gc_enable(sc);
4911           sc->tok = token(sc);
4912           if (sc->tok == TOK_EOF)
4913                { s_return(sc,sc->EOF_OBJ); }
4914           else if (sc->tok == TOK_RPAREN) {
4915                int c = inchar(sc);
4916                if (c != '\n')
4917                  backchar(sc,c);
4918 #if SHOW_ERROR_LINE
4919                else if (sc->load_stack[sc->file_i].kind & port_file)
4920                   sc->load_stack[sc->file_i].rep.stdio.curr_line++;
4921 #endif
4922                sc->nesting_stack[sc->file_i]--;
4923                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
4924           } else if (sc->tok == TOK_DOT) {
4925                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
4926                sc->tok = token(sc);
4927                s_thread_to(sc,OP_RDSEXPR);
4928           } else {
4929                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
4930                s_thread_to(sc,OP_RDSEXPR);
4931           }
4932      }
4933
4934      CASE(OP_RDDOT):
4935           if (token(sc) != TOK_RPAREN) {
4936                Error_0(sc,"syntax error: illegal dot expression");
4937           } else {
4938                sc->nesting_stack[sc->file_i]--;
4939                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
4940           }
4941
4942      CASE(OP_RDQUOTE):
4943           gc_disable(sc, 2);
4944           s_return_enable_gc(sc, cons(sc, sc->QUOTE,
4945                                       cons(sc, sc->value, sc->NIL)));
4946
4947      CASE(OP_RDQQUOTE):
4948           gc_disable(sc, 2);
4949           s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
4950                                       cons(sc, sc->value, sc->NIL)));
4951
4952      CASE(OP_RDQQUOTEVEC):
4953           gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
4954           s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
4955            cons(sc, mk_symbol(sc,"vector"),
4956                  cons(sc,cons(sc, sc->QQUOTE,
4957                   cons(sc,sc->value,sc->NIL)),
4958                   sc->NIL))));
4959
4960      CASE(OP_RDUNQUOTE):
4961           gc_disable(sc, 2);
4962           s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
4963                                       cons(sc, sc->value, sc->NIL)));
4964
4965      CASE(OP_RDUQTSP):
4966           gc_disable(sc, 2);
4967           s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
4968                                       cons(sc, sc->value, sc->NIL)));
4969
4970      CASE(OP_RDVEC):
4971           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4972           s_goto(sc,OP_EVAL); Cannot be quoted*/
4973           /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4974           s_return(sc,x); Cannot be part of pairs*/
4975           /*sc->code=mk_proc(sc,OP_VECTOR);
4976           sc->args=sc->value;
4977           s_goto(sc,OP_APPLY);*/
4978           sc->args=sc->value;
4979           s_goto(sc,OP_VECTOR);
4980
4981      /* ========== printing part ========== */
4982      CASE(OP_P0LIST):
4983           if(is_vector(sc->args)) {
4984                putstr(sc,"#(");
4985                sc->args=cons(sc,sc->args,mk_integer(sc,0));
4986                s_thread_to(sc,OP_PVECFROM);
4987           } else if(is_environment(sc->args)) {
4988                putstr(sc,"#<ENVIRONMENT>");
4989                s_return(sc,sc->T);
4990           } else if (!is_pair(sc->args)) {
4991                printatom(sc, sc->args, sc->print_flag);
4992                s_return(sc,sc->T);
4993           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
4994                putstr(sc, "'");
4995                sc->args = cadr(sc->args);
4996                s_thread_to(sc,OP_P0LIST);
4997           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
4998                putstr(sc, "`");
4999                sc->args = cadr(sc->args);
5000                s_thread_to(sc,OP_P0LIST);
5001           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
5002                putstr(sc, ",");
5003                sc->args = cadr(sc->args);
5004                s_thread_to(sc,OP_P0LIST);
5005           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
5006                putstr(sc, ",@");
5007                sc->args = cadr(sc->args);
5008                s_thread_to(sc,OP_P0LIST);
5009           } else {
5010                putstr(sc, "(");
5011                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5012                sc->args = car(sc->args);
5013                s_thread_to(sc,OP_P0LIST);
5014           }
5015
5016      CASE(OP_P1LIST):
5017           if (is_pair(sc->args)) {
5018             s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5019             putstr(sc, " ");
5020             sc->args = car(sc->args);
5021             s_thread_to(sc,OP_P0LIST);
5022           } else if(is_vector(sc->args)) {
5023             s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
5024             putstr(sc, " . ");
5025             s_thread_to(sc,OP_P0LIST);
5026           } else {
5027             if (sc->args != sc->NIL) {
5028               putstr(sc, " . ");
5029               printatom(sc, sc->args, sc->print_flag);
5030             }
5031             putstr(sc, ")");
5032             s_return(sc,sc->T);
5033           }
5034      CASE(OP_PVECFROM): {
5035           int i=ivalue_unchecked(cdr(sc->args));
5036           pointer vec=car(sc->args);
5037           int len=ivalue_unchecked(vec);
5038           if(i==len) {
5039                putstr(sc,")");
5040                s_return(sc,sc->T);
5041           } else {
5042                pointer elem=vector_elem(vec,i);
5043                ivalue_unchecked(cdr(sc->args))=i+1;
5044                s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
5045                sc->args=elem;
5046                if (i > 0)
5047                    putstr(sc," ");
5048                s_thread_to(sc,OP_P0LIST);
5049           }
5050      }
5051
5052      default:
5053           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5054           Error_0(sc,sc->strbuff);
5055
5056      }
5057      return sc->T;
5058 }
5059
5060 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
5061      pointer x, y;
5062      long v;
5063
5064      switch (op) {
5065      CASE(OP_LIST_LENGTH):     /* length */   /* a.k */
5066           v=list_length(sc,car(sc->args));
5067           if(v<0) {
5068                Error_1(sc,"length: not a list:",car(sc->args));
5069           }
5070           gc_disable(sc, 1);
5071           s_return_enable_gc(sc, mk_integer(sc, v));
5072
5073      CASE(OP_ASSQ):       /* assq */     /* a.k */
5074           x = car(sc->args);
5075           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
5076                if (!is_pair(car(y))) {
5077                     Error_0(sc,"unable to handle non pair element");
5078                }
5079                if (x == caar(y))
5080                     break;
5081           }
5082           if (is_pair(y)) {
5083                s_return(sc,car(y));
5084           } else {
5085                s_return(sc,sc->F);
5086           }
5087
5088
5089      CASE(OP_GET_CLOSURE):     /* get-closure-code */   /* a.k */
5090           sc->args = car(sc->args);
5091           if (sc->args == sc->NIL) {
5092                s_return(sc,sc->F);
5093           } else if (is_closure(sc->args)) {
5094                gc_disable(sc, 1);
5095                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5096                                            closure_code(sc->value)));
5097           } else if (is_macro(sc->args)) {
5098                gc_disable(sc, 1);
5099                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5100                                            closure_code(sc->value)));
5101           } else {
5102                s_return(sc,sc->F);
5103           }
5104      CASE(OP_CLOSUREP):        /* closure? */
5105           /*
5106            * Note, macro object is also a closure.
5107            * Therefore, (closure? <#MACRO>) ==> #t
5108            */
5109           s_retbool(is_closure(car(sc->args)));
5110      CASE(OP_MACROP):          /* macro? */
5111           s_retbool(is_macro(car(sc->args)));
5112      CASE(OP_VM_HISTORY):          /* *vm-history* */
5113           s_return(sc, history_flatten(sc));
5114      default:
5115           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5116           Error_0(sc,sc->strbuff);
5117      }
5118      return sc->T; /* NOTREACHED */
5119 }
5120
5121 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
5122
5123 typedef int (*test_predicate)(pointer);
5124
5125 static int is_any(pointer p) {
5126    (void)p;
5127    return 1;
5128 }
5129
5130 static int is_nonneg(pointer p) {
5131   return ivalue(p)>=0 && is_integer(p);
5132 }
5133
5134 /* Correspond carefully with following defines! */
5135 static struct {
5136   test_predicate fct;
5137   const char *kind;
5138 } tests[]={
5139   {0,0}, /* unused */
5140   {is_any, 0},
5141   {is_string, "string"},
5142   {is_symbol, "symbol"},
5143   {is_port, "port"},
5144   {is_inport,"input port"},
5145   {is_outport,"output port"},
5146   {is_environment, "environment"},
5147   {is_pair, "pair"},
5148   {0, "pair or '()"},
5149   {is_character, "character"},
5150   {is_vector, "vector"},
5151   {is_number, "number"},
5152   {is_integer, "integer"},
5153   {is_nonneg, "non-negative integer"}
5154 };
5155
5156 #define TST_NONE 0
5157 #define TST_ANY "\001"
5158 #define TST_STRING "\002"
5159 #define TST_SYMBOL "\003"
5160 #define TST_PORT "\004"
5161 #define TST_INPORT "\005"
5162 #define TST_OUTPORT "\006"
5163 #define TST_ENVIRONMENT "\007"
5164 #define TST_PAIR "\010"
5165 #define TST_LIST "\011"
5166 #define TST_CHAR "\012"
5167 #define TST_VECTOR "\013"
5168 #define TST_NUMBER "\014"
5169 #define TST_INTEGER "\015"
5170 #define TST_NATURAL "\016"
5171
5172 typedef struct {
5173   dispatch_func func;
5174   char *name;
5175   int min_arity;
5176   int max_arity;
5177   char *arg_tests_encoding;
5178 } op_code_info;
5179
5180 #define INF_ARG 0xffff
5181
5182 static op_code_info dispatch_table[]= {
5183 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
5184 #include "opdefines.h"
5185   { 0 }
5186 };
5187
5188 static const char *procname(pointer x) {
5189  int n=procnum(x);
5190  const char *name=dispatch_table[n].name;
5191  if(name==0) {
5192      name="ILLEGAL!";
5193  }
5194  return name;
5195 }
5196
5197 /* kernel of this interpreter */
5198 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
5199   sc->op = op;
5200   for (;;) {
5201     op_code_info *pcd=dispatch_table+sc->op;
5202     if (pcd->name!=0) { /* if built-in function, check arguments */
5203       char msg[STRBUFFSIZE];
5204       int ok=1;
5205       int n=list_length(sc,sc->args);
5206
5207       /* Check number of arguments */
5208       if(n<pcd->min_arity) {
5209         ok=0;
5210         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5211         pcd->name,
5212         pcd->min_arity==pcd->max_arity?"":" at least",
5213         pcd->min_arity);
5214       }
5215       if(ok && n>pcd->max_arity) {
5216         ok=0;
5217         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5218         pcd->name,
5219         pcd->min_arity==pcd->max_arity?"":" at most",
5220         pcd->max_arity);
5221       }
5222       if(ok) {
5223         if(pcd->arg_tests_encoding!=0) {
5224           int i=0;
5225           int j;
5226           const char *t=pcd->arg_tests_encoding;
5227           pointer arglist=sc->args;
5228           do {
5229             pointer arg=car(arglist);
5230             j=(int)t[0];
5231             if(j==TST_LIST[0]) {
5232                   if(arg!=sc->NIL && !is_pair(arg)) break;
5233             } else {
5234               if(!tests[j].fct(arg)) break;
5235             }
5236
5237             if(t[1]!=0) {/* last test is replicated as necessary */
5238               t++;
5239             }
5240             arglist=cdr(arglist);
5241             i++;
5242           } while(i<n);
5243           if(i<n) {
5244             ok=0;
5245             snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
5246                 pcd->name,
5247                 i+1,
5248                 tests[j].kind,
5249                 type_to_string(type(car(arglist))));
5250           }
5251         }
5252       }
5253       if(!ok) {
5254         if(_Error_1(sc,msg,0)==sc->NIL) {
5255           return;
5256         }
5257         pcd=dispatch_table+sc->op;
5258       }
5259     }
5260     ok_to_freely_gc(sc);
5261     if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
5262       return;
5263     }
5264     if(sc->no_memory) {
5265       fprintf(stderr,"No memory!\n");
5266       exit(1);
5267     }
5268   }
5269 }
5270
5271 /* ========== Initialization of internal keywords ========== */
5272
5273 static void assign_syntax(scheme *sc, char *name) {
5274      pointer x;
5275
5276      x = oblist_add_by_name(sc, name);
5277      typeflag(x) |= T_SYNTAX;
5278 }
5279
5280 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
5281      pointer x, y;
5282
5283      x = mk_symbol(sc, name);
5284      y = mk_proc(sc,op);
5285      new_slot_in_env(sc, x, y);
5286 }
5287
5288 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
5289      pointer y;
5290
5291      y = get_cell(sc, sc->NIL, sc->NIL);
5292      typeflag(y) = (T_PROC | T_ATOM);
5293      ivalue_unchecked(y) = (long) op;
5294      set_num_integer(y);
5295      return y;
5296 }
5297
5298 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5299 static int syntaxnum(pointer p) {
5300      const char *s=strvalue(car(p));
5301      switch(strlength(car(p))) {
5302      case 2:
5303           if(s[0]=='i') return OP_IF0;        /* if */
5304           else return OP_OR0;                 /* or */
5305      case 3:
5306           if(s[0]=='a') return OP_AND0;      /* and */
5307           else return OP_LET0;               /* let */
5308      case 4:
5309           switch(s[3]) {
5310           case 'e': return OP_CASE0;         /* case */
5311           case 'd': return OP_COND0;         /* cond */
5312           case '*': return OP_LET0AST;       /* let* */
5313           default: return OP_SET0;           /* set! */
5314           }
5315      case 5:
5316           switch(s[2]) {
5317           case 'g': return OP_BEGIN;         /* begin */
5318           case 'l': return OP_DELAY;         /* delay */
5319           case 'c': return OP_MACRO0;        /* macro */
5320           default: return OP_QUOTE;          /* quote */
5321           }
5322      case 6:
5323           switch(s[2]) {
5324           case 'm': return OP_LAMBDA;        /* lambda */
5325           case 'f': return OP_DEF0;          /* define */
5326           default: return OP_LET0REC;        /* letrec */
5327           }
5328      default:
5329           return OP_C0STREAM;                /* cons-stream */
5330      }
5331 }
5332
5333 /* initialization of TinyScheme */
5334 #if USE_INTERFACE
5335 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
5336  return cons(sc,a,b);
5337 }
5338 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
5339  return immutable_cons(sc,a,b);
5340 }
5341
5342 static struct scheme_interface vtbl ={
5343   scheme_define,
5344   s_cons,
5345   s_immutable_cons,
5346   reserve_cells,
5347   mk_integer,
5348   mk_real,
5349   mk_symbol,
5350   gensym,
5351   mk_string,
5352   mk_counted_string,
5353   mk_character,
5354   mk_vector,
5355   mk_foreign_func,
5356   mk_foreign_object,
5357   get_foreign_object_vtable,
5358   get_foreign_object_data,
5359   putstr,
5360   putcharacter,
5361
5362   is_string,
5363   string_value,
5364   is_number,
5365   nvalue,
5366   ivalue,
5367   rvalue,
5368   is_integer,
5369   is_real,
5370   is_character,
5371   charvalue,
5372   is_list,
5373   is_vector,
5374   list_length,
5375   ivalue,
5376   fill_vector,
5377   vector_elem,
5378   set_vector_elem,
5379   is_port,
5380   is_pair,
5381   pair_car,
5382   pair_cdr,
5383   set_car,
5384   set_cdr,
5385
5386   is_symbol,
5387   symname,
5388
5389   is_syntax,
5390   is_proc,
5391   is_foreign,
5392   syntaxname,
5393   is_closure,
5394   is_macro,
5395   closure_code,
5396   closure_env,
5397
5398   is_continuation,
5399   is_promise,
5400   is_environment,
5401   is_immutable,
5402   setimmutable,
5403
5404   scheme_load_file,
5405   scheme_load_string,
5406   port_from_file
5407 };
5408 #endif
5409
5410 scheme *scheme_init_new() {
5411   scheme *sc=(scheme*)malloc(sizeof(scheme));
5412   if(!scheme_init(sc)) {
5413     free(sc);
5414     return 0;
5415   } else {
5416     return sc;
5417   }
5418 }
5419
5420 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
5421   scheme *sc=(scheme*)malloc(sizeof(scheme));
5422   if(!scheme_init_custom_alloc(sc,malloc,free)) {
5423     free(sc);
5424     return 0;
5425   } else {
5426     return sc;
5427   }
5428 }
5429
5430
5431 int scheme_init(scheme *sc) {
5432  return scheme_init_custom_alloc(sc,malloc,free);
5433 }
5434
5435 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
5436   int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
5437   pointer x;
5438
5439   num_zero.is_fixnum=1;
5440   num_zero.value.ivalue=0;
5441   num_one.is_fixnum=1;
5442   num_one.value.ivalue=1;
5443
5444 #if USE_INTERFACE
5445   sc->vptr=&vtbl;
5446 #endif
5447   sc->gensym_cnt=0;
5448   sc->malloc=malloc;
5449   sc->free=free;
5450   sc->last_cell_seg = -1;
5451   sc->sink = &sc->_sink;
5452   sc->NIL = &sc->_NIL;
5453   sc->T = &sc->_HASHT;
5454   sc->F = &sc->_HASHF;
5455   sc->EOF_OBJ=&sc->_EOF_OBJ;
5456
5457 #if USE_SMALL_INTEGERS
5458   if (initialize_small_integers(sc)) {
5459     sc->no_memory=1;
5460     return 0;
5461   }
5462 #endif
5463
5464   sc->free_cell = &sc->_NIL;
5465   sc->fcells = 0;
5466   sc->inhibit_gc = GC_ENABLED;
5467   sc->reserved_cells = 0;
5468   sc->reserved_lineno = 0;
5469   sc->no_memory=0;
5470   sc->inport=sc->NIL;
5471   sc->outport=sc->NIL;
5472   sc->save_inport=sc->NIL;
5473   sc->loadport=sc->NIL;
5474   sc->nesting=0;
5475   memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
5476   sc->interactive_repl=0;
5477   sc->strbuff = sc->malloc(STRBUFFSIZE);
5478   if (sc->strbuff == 0) {
5479      sc->no_memory=1;
5480      return 0;
5481   }
5482   sc->strbuff_size = STRBUFFSIZE;
5483
5484   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
5485     sc->no_memory=1;
5486     return 0;
5487   }
5488   sc->gc_verbose = 0;
5489   dump_stack_initialize(sc);
5490   sc->code = sc->NIL;
5491   sc->tracing=0;
5492   sc->op = -1;
5493   sc->flags = 0;
5494
5495   /* init sc->NIL */
5496   typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
5497   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
5498   /* init T */
5499   typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
5500   car(sc->T) = cdr(sc->T) = sc->T;
5501   /* init F */
5502   typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
5503   car(sc->F) = cdr(sc->F) = sc->F;
5504   /* init EOF_OBJ */
5505   typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
5506   car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
5507   /* init sink */
5508   typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
5509   car(sc->sink) = cdr(sc->sink) = sc->NIL;
5510   /* init c_nest */
5511   sc->c_nest = sc->NIL;
5512
5513   sc->oblist = oblist_initial_value(sc);
5514   /* init global_env */
5515   new_frame_in_env(sc, sc->NIL);
5516   sc->global_env = sc->envir;
5517   /* init else */
5518   x = mk_symbol(sc,"else");
5519   new_slot_in_env(sc, x, sc->T);
5520
5521   assign_syntax(sc, "lambda");
5522   assign_syntax(sc, "quote");
5523   assign_syntax(sc, "define");
5524   assign_syntax(sc, "if");
5525   assign_syntax(sc, "begin");
5526   assign_syntax(sc, "set!");
5527   assign_syntax(sc, "let");
5528   assign_syntax(sc, "let*");
5529   assign_syntax(sc, "letrec");
5530   assign_syntax(sc, "cond");
5531   assign_syntax(sc, "delay");
5532   assign_syntax(sc, "and");
5533   assign_syntax(sc, "or");
5534   assign_syntax(sc, "cons-stream");
5535   assign_syntax(sc, "macro");
5536   assign_syntax(sc, "case");
5537
5538   for(i=0; i<n; i++) {
5539     if(dispatch_table[i].name!=0) {
5540       assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
5541     }
5542   }
5543
5544   history_init(sc, 8, 8);
5545
5546   /* initialization of global pointers to special symbols */
5547   sc->LAMBDA = mk_symbol(sc, "lambda");
5548   sc->QUOTE = mk_symbol(sc, "quote");
5549   sc->QQUOTE = mk_symbol(sc, "quasiquote");
5550   sc->UNQUOTE = mk_symbol(sc, "unquote");
5551   sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
5552   sc->FEED_TO = mk_symbol(sc, "=>");
5553   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
5554   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
5555   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
5556 #if USE_COMPILE_HOOK
5557   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
5558 #endif
5559
5560   return !sc->no_memory;
5561 }
5562
5563 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
5564   sc->inport=port_from_file(sc,fin,port_input);
5565 }
5566
5567 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
5568   sc->inport=port_from_string(sc,start,past_the_end,port_input);
5569 }
5570
5571 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
5572   sc->outport=port_from_file(sc,fout,port_output);
5573 }
5574
5575 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
5576   sc->outport=port_from_string(sc,start,past_the_end,port_output);
5577 }
5578
5579 void scheme_set_external_data(scheme *sc, void *p) {
5580  sc->ext_data=p;
5581 }
5582
5583 void scheme_deinit(scheme *sc) {
5584   int i;
5585
5586 #if SHOW_ERROR_LINE
5587   char *fname;
5588 #endif
5589
5590   sc->oblist=sc->NIL;
5591   sc->global_env=sc->NIL;
5592   dump_stack_free(sc);
5593   sc->envir=sc->NIL;
5594   sc->code=sc->NIL;
5595   history_free(sc);
5596   sc->args=sc->NIL;
5597   sc->value=sc->NIL;
5598   if(is_port(sc->inport)) {
5599     typeflag(sc->inport) = T_ATOM;
5600   }
5601   sc->inport=sc->NIL;
5602   sc->outport=sc->NIL;
5603   if(is_port(sc->save_inport)) {
5604     typeflag(sc->save_inport) = T_ATOM;
5605   }
5606   sc->save_inport=sc->NIL;
5607   if(is_port(sc->loadport)) {
5608     typeflag(sc->loadport) = T_ATOM;
5609   }
5610   sc->loadport=sc->NIL;
5611   sc->gc_verbose=0;
5612   gc(sc,sc->NIL,sc->NIL);
5613
5614 #if USE_SMALL_INTEGERS
5615   sc->free(sc->integer_alloc);
5616 #endif
5617
5618   for(i=0; i<=sc->last_cell_seg; i++) {
5619     sc->free(sc->alloc_seg[i]);
5620   }
5621   sc->free(sc->strbuff);
5622
5623 #if SHOW_ERROR_LINE
5624   for(i=0; i<=sc->file_i; i++) {
5625     if (sc->load_stack[i].kind & port_file) {
5626       fname = sc->load_stack[i].rep.stdio.filename;
5627       if(fname)
5628         sc->free(fname);
5629     }
5630   }
5631 #endif
5632 }
5633
5634 void scheme_load_file(scheme *sc, FILE *fin)
5635 { scheme_load_named_file(sc,fin,0); }
5636
5637 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
5638   dump_stack_reset(sc);
5639   sc->envir = sc->global_env;
5640   sc->file_i=0;
5641   sc->load_stack[0].kind=port_input|port_file;
5642   sc->load_stack[0].rep.stdio.file=fin;
5643   sc->loadport=mk_port(sc,sc->load_stack);
5644   sc->retcode=0;
5645   if(fin==stdin) {
5646     sc->interactive_repl=1;
5647   }
5648
5649 #if SHOW_ERROR_LINE
5650   sc->load_stack[0].rep.stdio.curr_line = 0;
5651   if(fin!=stdin && filename)
5652     sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
5653   else
5654     sc->load_stack[0].rep.stdio.filename = NULL;
5655 #endif
5656
5657   sc->inport=sc->loadport;
5658   sc->args = mk_integer(sc,sc->file_i);
5659   Eval_Cycle(sc, OP_T0LVL);
5660   typeflag(sc->loadport)=T_ATOM;
5661   if(sc->retcode==0) {
5662     sc->retcode=sc->nesting!=0;
5663   }
5664
5665 #if SHOW_ERROR_LINE
5666   sc->free(sc->load_stack[0].rep.stdio.filename);
5667   sc->load_stack[0].rep.stdio.filename = NULL;
5668 #endif
5669 }
5670
5671 void scheme_load_string(scheme *sc, const char *cmd) {
5672   dump_stack_reset(sc);
5673   sc->envir = sc->global_env;
5674   sc->file_i=0;
5675   sc->load_stack[0].kind=port_input|port_string;
5676   sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
5677   sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
5678   sc->load_stack[0].rep.string.curr=(char*)cmd;
5679   sc->loadport=mk_port(sc,sc->load_stack);
5680   sc->retcode=0;
5681   sc->interactive_repl=0;
5682   sc->inport=sc->loadport;
5683   sc->args = mk_integer(sc,sc->file_i);
5684   Eval_Cycle(sc, OP_T0LVL);
5685   typeflag(sc->loadport)=T_ATOM;
5686   if(sc->retcode==0) {
5687     sc->retcode=sc->nesting!=0;
5688   }
5689 }
5690
5691 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
5692      pointer x;
5693
5694      x=find_slot_in_env(sc,envir,symbol,0);
5695      if (x != sc->NIL) {
5696           set_slot_in_env(sc, x, value);
5697      } else {
5698           new_slot_spec_in_env(sc, envir, symbol, value);
5699      }
5700 }
5701
5702 #if !STANDALONE
5703 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
5704 {
5705   scheme_define(sc,
5706                 sc->global_env,
5707                 mk_symbol(sc,sr->name),
5708                 mk_foreign_func(sc, sr->f));
5709 }
5710
5711 void scheme_register_foreign_func_list(scheme * sc,
5712                                        scheme_registerable * list,
5713                                        int count)
5714 {
5715   int i;
5716   for(i = 0; i < count; i++)
5717     {
5718       scheme_register_foreign_func(sc, list + i);
5719     }
5720 }
5721
5722 pointer scheme_apply0(scheme *sc, const char *procname)
5723 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
5724
5725 void save_from_C_call(scheme *sc)
5726 {
5727   pointer saved_data =
5728     cons(sc,
5729          car(sc->sink),
5730          cons(sc,
5731               sc->envir,
5732               sc->dump));
5733   /* Push */
5734   sc->c_nest = cons(sc, saved_data, sc->c_nest);
5735   /* Truncate the dump stack so TS will return here when done, not
5736      directly resume pre-C-call operations. */
5737   dump_stack_reset(sc);
5738 }
5739 void restore_from_C_call(scheme *sc)
5740 {
5741   car(sc->sink) = caar(sc->c_nest);
5742   sc->envir = cadar(sc->c_nest);
5743   sc->dump = cdr(cdar(sc->c_nest));
5744   /* Pop */
5745   sc->c_nest = cdr(sc->c_nest);
5746 }
5747
5748 /* "func" and "args" are assumed to be already eval'ed. */
5749 pointer scheme_call(scheme *sc, pointer func, pointer args)
5750 {
5751   int old_repl = sc->interactive_repl;
5752   sc->interactive_repl = 0;
5753   save_from_C_call(sc);
5754   sc->envir = sc->global_env;
5755   sc->args = args;
5756   sc->code = func;
5757   sc->retcode = 0;
5758   Eval_Cycle(sc, OP_APPLY);
5759   sc->interactive_repl = old_repl;
5760   restore_from_C_call(sc);
5761   return sc->value;
5762 }
5763
5764 pointer scheme_eval(scheme *sc, pointer obj)
5765 {
5766   int old_repl = sc->interactive_repl;
5767   sc->interactive_repl = 0;
5768   save_from_C_call(sc);
5769   sc->args = sc->NIL;
5770   sc->code = obj;
5771   sc->retcode = 0;
5772   Eval_Cycle(sc, OP_EVAL);
5773   sc->interactive_repl = old_repl;
5774   restore_from_C_call(sc);
5775   return sc->value;
5776 }
5777
5778
5779 #endif
5780
5781 /* ========== Main ========== */
5782
5783 #if STANDALONE
5784
5785 #if defined(__APPLE__) && !defined (OSX)
5786 int main()
5787 {
5788      extern MacTS_main(int argc, char **argv);
5789      char**    argv;
5790      int argc = ccommand(&argv);
5791      MacTS_main(argc,argv);
5792      return 0;
5793 }
5794 int MacTS_main(int argc, char **argv) {
5795 #else
5796 int main(int argc, char **argv) {
5797 #endif
5798   scheme sc;
5799   FILE *fin;
5800   char *file_name=InitFile;
5801   int retcode;
5802   int isfile=1;
5803
5804   if(argc==1) {
5805     printf(banner);
5806   }
5807   if(argc==2 && strcmp(argv[1],"-?")==0) {
5808     printf("Usage: tinyscheme -?\n");
5809     printf("or:    tinyscheme [<file1> <file2> ...]\n");
5810     printf("followed by\n");
5811     printf("          -1 <file> [<arg1> <arg2> ...]\n");
5812     printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
5813     printf("assuming that the executable is named tinyscheme.\n");
5814     printf("Use - as filename for stdin.\n");
5815     return 1;
5816   }
5817   if(!scheme_init(&sc)) {
5818     fprintf(stderr,"Could not initialize!\n");
5819     return 2;
5820   }
5821   scheme_set_input_port_file(&sc, stdin);
5822   scheme_set_output_port_file(&sc, stdout);
5823 #if USE_DL
5824   scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
5825 #endif
5826   argv++;
5827   if(access(file_name,0)!=0) {
5828     char *p=getenv("TINYSCHEMEINIT");
5829     if(p!=0) {
5830       file_name=p;
5831     }
5832   }
5833   do {
5834     if(strcmp(file_name,"-")==0) {
5835       fin=stdin;
5836     } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
5837       pointer args=sc.NIL;
5838       isfile=file_name[1]=='1';
5839       file_name=*argv++;
5840       if(strcmp(file_name,"-")==0) {
5841         fin=stdin;
5842       } else if(isfile) {
5843         fin=fopen(file_name,"r");
5844       }
5845       for(;*argv;argv++) {
5846         pointer value=mk_string(&sc,*argv);
5847         args=cons(&sc,value,args);
5848       }
5849       args=reverse_in_place(&sc,sc.NIL,args);
5850       scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
5851
5852     } else {
5853       fin=fopen(file_name,"r");
5854     }
5855     if(isfile && fin==0) {
5856       fprintf(stderr,"Could not open file %s\n",file_name);
5857     } else {
5858       if(isfile) {
5859         scheme_load_named_file(&sc,fin,file_name);
5860       } else {
5861         scheme_load_string(&sc,file_name);
5862       }
5863       if(!isfile || fin!=stdin) {
5864         if(sc.retcode!=0) {
5865           fprintf(stderr,"Errors encountered reading %s\n",file_name);
5866         }
5867         if(isfile) {
5868           fclose(fin);
5869         }
5870       }
5871     }
5872     file_name=*argv++;
5873   } while(file_name!=0);
5874   if(argc==1) {
5875     scheme_load_named_file(&sc,stdin,0);
5876   }
5877   retcode=sc.retcode;
5878   scheme_deinit(&sc);
5879
5880   return retcode;
5881 }
5882
5883 #endif
5884
5885 /*
5886 Local variables:
5887 c-file-style: "k&r"
5888 End:
5889 */