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