tests/gpgscm/scheme.c

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