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 #define CASE(OP)        case OP: if (0) goto OP; OP
2994
2995 #else   /* USE_THREADED_CODE */
2996 #define s_thread_to(sc, a)      s_goto(sc, a)
2997 #define CASE(OP)                case OP
2998 #endif  /* USE_THREADED_CODE */
2999
3000 /* Return to the previous frame on the dump stack, setting the current
3001  * value to A.  */
3002 #define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0))
3003
3004 /* Return to the previous frame on the dump stack, setting the current
3005  * value to A, and re-enable the garbage collector.  */
3006 #define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1))
3007
3008 static INLINE void dump_stack_reset(scheme *sc)
3009 {
3010   sc->dump = sc->NIL;
3011 }
3012
3013 static INLINE void dump_stack_initialize(scheme *sc)
3014 {
3015   dump_stack_reset(sc);
3016   sc->frame_freelist = sc->NIL;
3017 }
3018
3019 static void dump_stack_free(scheme *sc)
3020 {
3021   dump_stack_initialize(sc);
3022 }
3023
3024 const int frame_length = 4;
3025
3026 static pointer
3027 dump_stack_make_frame(scheme *sc)
3028 {
3029   pointer frame;
3030
3031   frame = mk_vector(sc, frame_length);
3032   if (! sc->no_memory)
3033     setframe(frame);
3034
3035   return frame;
3036 }
3037
3038 static INLINE pointer *
3039 frame_slots(pointer frame)
3040 {
3041   return &frame->_object._vector._elements[0];
3042 }
3043
3044 #define frame_payload   vector_length
3045
3046 static pointer
3047 dump_stack_allocate_frame(scheme *sc)
3048 {
3049   pointer frame = sc->frame_freelist;
3050   if (frame == sc->NIL) {
3051     if (gc_enabled(sc))
3052       frame = dump_stack_make_frame(sc);
3053     else
3054       gc_reservation_failure(sc);
3055   } else
3056     sc->frame_freelist = *frame_slots(frame);
3057   return frame;
3058 }
3059
3060 static void
3061 dump_stack_deallocate_frame(scheme *sc, pointer frame)
3062 {
3063   pointer *p = frame_slots(frame);
3064   *p++ = sc->frame_freelist;
3065   *p++ = sc->NIL;
3066   *p++ = sc->NIL;
3067   *p++ = sc->NIL;
3068   sc->frame_freelist = frame;
3069 }
3070
3071 static void
3072 dump_stack_preallocate_frame(scheme *sc)
3073 {
3074   pointer frame = dump_stack_make_frame(sc);
3075   if (! sc->no_memory)
3076     dump_stack_deallocate_frame(sc, frame);
3077 }
3078
3079 static enum scheme_opcodes
3080 _s_return(scheme *sc, pointer a, int enable_gc) {
3081   pointer dump = sc->dump;
3082   pointer *p;
3083   unsigned long v;
3084   enum scheme_opcodes next_op;
3085   sc->value = (a);
3086   if (enable_gc)
3087        gc_enable(sc);
3088   if (dump == sc->NIL)
3089     return OP_QUIT;
3090   v = frame_payload(dump);
3091   next_op = (int) (v & S_OP_MASK);
3092   sc->flags = v & S_FLAG_MASK;
3093   p = frame_slots(dump);
3094   sc->args = *p++;
3095   sc->envir = *p++;
3096   sc->code = *p++;
3097   sc->dump = *p++;
3098   dump_stack_deallocate_frame(sc, dump);
3099   return next_op;
3100 }
3101
3102 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
3103 #define s_save_allocates        0
3104     pointer dump;
3105     pointer *p;
3106     gc_disable(sc, gc_reservations (s_save));
3107     dump = dump_stack_allocate_frame(sc);
3108     frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op);
3109     p = frame_slots(dump);
3110     *p++ = args;
3111     *p++ = sc->envir;
3112     *p++ = code;
3113     *p++ = sc->dump;
3114     sc->dump = dump;
3115     gc_enable(sc);
3116 }
3117
3118 static INLINE void dump_stack_mark(scheme *sc)
3119 {
3120   mark(sc->dump);
3121   mark(sc->frame_freelist);
3122 }
3123
3124 \f
3125
3126 #if USE_HISTORY
3127
3128 static void
3129 history_free(scheme *sc)
3130 {
3131   sc->free(sc->history.m);
3132   sc->history.tailstacks = sc->NIL;
3133   sc->history.callstack = sc->NIL;
3134 }
3135
3136 static pointer
3137 history_init(scheme *sc, size_t N, size_t M)
3138 {
3139   size_t i;
3140   struct history *h = &sc->history;
3141
3142   h->N = N;
3143   h->mask_N = N - 1;
3144   h->n = N - 1;
3145   assert ((N & h->mask_N) == 0);
3146
3147   h->M = M;
3148   h->mask_M = M - 1;
3149   assert ((M & h->mask_M) == 0);
3150
3151   h->callstack = mk_vector(sc, N);
3152   if (h->callstack == sc->sink)
3153     goto fail;
3154
3155   h->tailstacks = mk_vector(sc, N);
3156   for (i = 0; i < N; i++) {
3157     pointer tailstack = mk_vector(sc, M);
3158     if (tailstack == sc->sink)
3159       goto fail;
3160     set_vector_elem(h->tailstacks, i, tailstack);
3161   }
3162
3163   h->m = sc->malloc(N * sizeof *h->m);
3164   if (h->m == NULL)
3165     goto fail;
3166
3167   for (i = 0; i < N; i++)
3168     h->m[i] = 0;
3169
3170   return sc->T;
3171
3172 fail:
3173   history_free(sc);
3174   return sc->F;
3175 }
3176
3177 static void
3178 history_mark(scheme *sc)
3179 {
3180   struct history *h = &sc->history;
3181   mark(h->callstack);
3182   mark(h->tailstacks);
3183 }
3184
3185 #define add_mod(a, b, mask)     (((a) + (b)) & (mask))
3186 #define sub_mod(a, b, mask)     add_mod(a, (mask) + 1 - (b), mask)
3187
3188 static INLINE void
3189 tailstack_clear(scheme *sc, pointer v)
3190 {
3191   assert(is_vector(v));
3192   /* XXX optimize */
3193   fill_vector(v, sc->NIL);
3194 }
3195
3196 static pointer
3197 callstack_pop(scheme *sc)
3198 {
3199   struct history *h = &sc->history;
3200   size_t n = h->n;
3201   pointer item;
3202
3203   if (h->callstack == sc->NIL)
3204     return sc->NIL;
3205
3206   item = vector_elem(h->callstack, n);
3207   /* Clear our frame so that it can be gc'ed and we don't run into it
3208    * when walking the history.  */
3209   set_vector_elem(h->callstack, n, sc->NIL);
3210   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3211
3212   /* Exit from the frame.  */
3213   h->n = sub_mod(h->n, 1, h->mask_N);
3214
3215   return item;
3216 }
3217
3218 static void
3219 callstack_push(scheme *sc, pointer item)
3220 {
3221   struct history *h = &sc->history;
3222   size_t n = h->n;
3223
3224   if (h->callstack == sc->NIL)
3225     return;
3226
3227   /* Enter a new frame.  */
3228   n = h->n = add_mod(n, 1, h->mask_N);
3229
3230   /* Initialize tail stack.  */
3231   tailstack_clear(sc, vector_elem(h->tailstacks, n));
3232   h->m[n] = h->mask_M;
3233
3234   set_vector_elem(h->callstack, n, item);
3235 }
3236
3237 static void
3238 tailstack_push(scheme *sc, pointer item)
3239 {
3240   struct history *h = &sc->history;
3241   size_t n = h->n;
3242   size_t m = h->m[n];
3243
3244   if (h->callstack == sc->NIL)
3245     return;
3246
3247   /* Enter a new tail frame.  */
3248   m = h->m[n] = add_mod(m, 1, h->mask_M);
3249   set_vector_elem(vector_elem(h->tailstacks, n), m, item);
3250 }
3251
3252 static pointer
3253 tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
3254                   pointer acc)
3255 {
3256   struct history *h = &sc->history;
3257   pointer frame;
3258
3259   assert(i <= h->M);
3260   assert(n < h->M);
3261
3262   if (acc == sc->sink)
3263     return sc->sink;
3264
3265   if (i == 0) {
3266     /* We reached the end, but we did not see a unused frame.  Signal
3267        this using '... .  */
3268     return cons(sc, mk_symbol(sc, "..."), acc);
3269   }
3270
3271   frame = vector_elem(tailstack, n);
3272   if (frame == sc->NIL) {
3273     /* A unused frame.  We reached the end of the history.  */
3274     return acc;
3275   }
3276
3277   /* Add us.  */
3278   acc = cons(sc, frame, acc);
3279
3280   return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
3281                            acc);
3282 }
3283
3284 static pointer
3285 callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
3286 {
3287   struct history *h = &sc->history;
3288   pointer frame;
3289
3290   assert(i <= h->N);
3291   assert(n < h->N);
3292
3293   if (acc == sc->sink)
3294     return sc->sink;
3295
3296   if (i == 0) {
3297     /* We reached the end, but we did not see a unused frame.  Signal
3298        this using '... .  */
3299     return cons(sc, mk_symbol(sc, "..."), acc);
3300   }
3301
3302   frame = vector_elem(h->callstack, n);
3303   if (frame == sc->NIL) {
3304     /* A unused frame.  We reached the end of the history.  */
3305     return acc;
3306   }
3307
3308   /* First, emit the tail calls.  */
3309   acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
3310                           acc);
3311
3312   /* Then us.  */
3313   acc = cons(sc, frame, acc);
3314
3315   return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
3316 }
3317
3318 static pointer
3319 history_flatten(scheme *sc)
3320 {
3321   struct history *h = &sc->history;
3322   pointer history;
3323
3324   if (h->callstack == sc->NIL)
3325     return sc->NIL;
3326
3327   history = callstack_flatten(sc, h->N, h->n, sc->NIL);
3328   if (history == sc->sink)
3329     return sc->sink;
3330
3331   return reverse_in_place(sc, sc->NIL, history);
3332 }
3333
3334 #undef add_mod
3335 #undef sub_mod
3336
3337 #else   /* USE_HISTORY */
3338
3339 #define history_init(SC, A, B)  (void) 0
3340 #define history_free(SC)        (void) 0
3341 #define callstack_pop(SC)       (void) 0
3342 #define callstack_push(SC, X)   (void) 0
3343 #define tailstack_push(SC, X)   (void) 0
3344
3345 #endif  /* USE_HISTORY */
3346
3347 \f
3348
3349 #if USE_PLIST
3350 static pointer
3351 get_property(scheme *sc, pointer obj, pointer key)
3352 {
3353   pointer x;
3354
3355   assert (is_symbol(obj));
3356   assert (is_symbol(key));
3357
3358   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3359     if (caar(x) == key)
3360       break;
3361   }
3362
3363   if (x != sc->NIL)
3364     return cdar(x);
3365
3366   return sc->NIL;
3367 }
3368
3369 static pointer
3370 set_property(scheme *sc, pointer obj, pointer key, pointer value)
3371 {
3372 #define set_property_allocates  2
3373   pointer x;
3374
3375   assert (is_symbol(obj));
3376   assert (is_symbol(key));
3377
3378   for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
3379     if (caar(x) == key)
3380       break;
3381   }
3382
3383   if (x != sc->NIL)
3384     cdar(x) = value;
3385   else {
3386     gc_disable(sc, gc_reservations(set_property));
3387     symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
3388     gc_enable(sc);
3389   }
3390
3391   return sc->T;
3392 }
3393 #endif
3394
3395 \f
3396
3397 static int is_list(scheme *sc, pointer a)
3398 { return list_length(sc,a) >= 0; }
3399
3400 /* Result is:
3401    proper list: length
3402    circular list: -1
3403    not even a pair: -2
3404    dotted list: -2 minus length before dot
3405 */
3406 int list_length(scheme *sc, pointer a) {
3407     int i=0;
3408     pointer slow, fast;
3409
3410     slow = fast = a;
3411     while (1)
3412     {
3413         if (fast == sc->NIL)
3414                 return i;
3415         if (!is_pair(fast))
3416                 return -2 - i;
3417         fast = cdr(fast);
3418         ++i;
3419         if (fast == sc->NIL)
3420                 return i;
3421         if (!is_pair(fast))
3422                 return -2 - i;
3423         ++i;
3424         fast = cdr(fast);
3425
3426         /* Safe because we would have already returned if `fast'
3427            encountered a non-pair. */
3428         slow = cdr(slow);
3429         if (fast == slow)
3430         {
3431             /* the fast pointer has looped back around and caught up
3432                with the slow pointer, hence the structure is circular,
3433                not of finite length, and therefore not a list */
3434             return -1;
3435         }
3436     }
3437 }
3438
3439 \f
3440
3441 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
3442
3443 /* kernel of this interpreter */
3444 static void
3445 Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
3446   for (;;) {
3447      pointer x, y;
3448      pointer callsite;
3449      num v;
3450 #if USE_MATH
3451      double dd;
3452 #endif
3453      int (*comp_func)(num, num) = NULL;
3454      const struct op_code_info *pcd;
3455
3456   dispatch:
3457      pcd = &dispatch_table[op];
3458      if (pcd->name[0] != 0) { /* if built-in function, check arguments */
3459        char msg[STRBUFFSIZE];
3460        if (! check_arguments (sc, pcd, msg, sizeof msg)) {
3461          s_goto(sc, _Error_1(sc, msg, 0));
3462        }
3463      }
3464
3465      if(sc->no_memory) {
3466        fprintf(stderr,"No memory!\n");
3467        exit(1);
3468      }
3469      ok_to_freely_gc(sc);
3470
3471      switch (op) {
3472      CASE(OP_LOAD):       /* load */
3473           if(file_interactive(sc)) {
3474                fprintf(sc->outport->_object._port->rep.stdio.file,
3475                "Loading %s\n", strvalue(car(sc->args)));
3476           }
3477           if (!file_push(sc, car(sc->args))) {
3478                Error_1(sc,"unable to open", car(sc->args));
3479           }
3480       else
3481         {
3482           sc->args = mk_integer(sc,sc->file_i);
3483           s_thread_to(sc,OP_T0LVL);
3484         }
3485
3486      CASE(OP_T0LVL): /* top level */
3487        /* If we reached the end of file, this loop is done. */
3488        if(sc->loadport->_object._port->kind & port_saw_EOF)
3489      {
3490        if(sc->file_i == 0)
3491          {
3492            sc->args=sc->NIL;
3493            sc->nesting = sc->nesting_stack[0];
3494            s_thread_to(sc,OP_QUIT);
3495          }
3496        else
3497          {
3498            file_pop(sc);
3499            s_return(sc,sc->value);
3500          }
3501        /* NOTREACHED */
3502      }
3503
3504        /* If interactive, be nice to user. */
3505        if(file_interactive(sc))
3506      {
3507        sc->envir = sc->global_env;
3508        dump_stack_reset(sc);
3509        putstr(sc,"\n");
3510        putstr(sc,prompt);
3511      }
3512
3513        /* Set up another iteration of REPL */
3514        sc->nesting=0;
3515        sc->save_inport=sc->inport;
3516        sc->inport = sc->loadport;
3517        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
3518        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
3519        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
3520        s_thread_to(sc,OP_READ_INTERNAL);
3521
3522      CASE(OP_T1LVL): /* top level */
3523           sc->code = sc->value;
3524           sc->inport=sc->save_inport;
3525           s_thread_to(sc,OP_EVAL);
3526
3527      CASE(OP_READ_INTERNAL):       /* internal read */
3528           sc->tok = token(sc);
3529           if(sc->tok==TOK_EOF)
3530         { s_return(sc,sc->EOF_OBJ); }
3531           s_thread_to(sc,OP_RDSEXPR);
3532
3533      CASE(OP_GENSYM):
3534           s_return(sc, gensym(sc));
3535
3536      CASE(OP_VALUEPRINT): /* print evaluation result */
3537           /* OP_VALUEPRINT is always pushed, because when changing from
3538              non-interactive to interactive mode, it needs to be
3539              already on the stack */
3540        if(sc->tracing) {
3541          putstr(sc,"\nGives: ");
3542        }
3543        if(file_interactive(sc)) {
3544          sc->print_flag = 1;
3545          sc->args = sc->value;
3546          s_thread_to(sc,OP_P0LIST);
3547        } else {
3548          s_return(sc,sc->value);
3549        }
3550
3551      CASE(OP_EVAL):       /* main part of evaluation */
3552 #if USE_TRACING
3553        if(sc->tracing) {
3554          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
3555          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
3556          sc->args=sc->code;
3557          putstr(sc,"\nEval: ");
3558          s_thread_to(sc,OP_P0LIST);
3559        }
3560        /* fall through */
3561      CASE(OP_REAL_EVAL):
3562 #endif
3563           if (is_symbol(sc->code)) {    /* symbol */
3564                x=find_slot_in_env(sc,sc->envir,sc->code,1);
3565                if (x != sc->NIL) {
3566                     s_return(sc,slot_value_in_env(x));
3567                } else {
3568                     Error_1(sc, "eval: unbound variable", sc->code);
3569                }
3570           } else if (is_pair(sc->code)) {
3571                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
3572                     sc->code = cdr(sc->code);
3573                     s_goto(sc, syntaxnum(sc, x));
3574                } else {/* first, eval top element and eval arguments */
3575                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
3576                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
3577                     sc->code = car(sc->code);
3578                     s_clear_flag(sc, TAIL_CONTEXT);
3579                     s_thread_to(sc,OP_EVAL);
3580                }
3581           } else {
3582                s_return(sc,sc->code);
3583           }
3584
3585      CASE(OP_E0ARGS):     /* eval arguments */
3586           if (is_macro(sc->value)) {    /* macro expansion */
3587                gc_disable(sc, 1 + gc_reservations (s_save));
3588                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
3589                sc->args = cons(sc,sc->code, sc->NIL);
3590                gc_enable(sc);
3591                sc->code = sc->value;
3592                s_clear_flag(sc, TAIL_CONTEXT);
3593                s_thread_to(sc,OP_APPLY);
3594           } else {
3595                gc_disable(sc, 1);
3596                sc->args = cons(sc, sc->code, sc->NIL);
3597                gc_enable(sc);
3598                sc->code = cdr(sc->code);
3599                s_thread_to(sc,OP_E1ARGS);
3600           }
3601
3602      CASE(OP_E1ARGS):     /* eval arguments */
3603           gc_disable(sc, 1);
3604           sc->args = cons(sc, sc->value, sc->args);
3605           gc_enable(sc);
3606           if (is_pair(sc->code)) { /* continue */
3607                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
3608                sc->code = car(sc->code);
3609                sc->args = sc->NIL;
3610                s_clear_flag(sc, TAIL_CONTEXT);
3611                s_thread_to(sc,OP_EVAL);
3612           } else {  /* end */
3613                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3614                s_thread_to(sc,OP_APPLY_CODE);
3615           }
3616
3617 #if USE_TRACING
3618      CASE(OP_TRACING): {
3619        int tr=sc->tracing;
3620        sc->tracing=ivalue(car(sc->args));
3621        gc_disable(sc, 1);
3622        s_return_enable_gc(sc, mk_integer(sc, tr));
3623      }
3624 #endif
3625
3626 #if USE_HISTORY
3627      CASE(OP_CALLSTACK_POP):      /* pop the call stack */
3628           callstack_pop(sc);
3629           s_return(sc, sc->value);
3630 #endif
3631
3632      CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
3633                            * record in the history as invoked from
3634                            * 'car(args)' */
3635           free_cons(sc, sc->args, &callsite, &sc->args);
3636           sc->code = car(sc->args);
3637           sc->args = cdr(sc->args);
3638           /* Fallthrough.  */
3639
3640      CASE(OP_APPLY):      /* apply 'code' to 'args' */
3641 #if USE_TRACING
3642        if(sc->tracing) {
3643          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
3644          sc->print_flag = 1;
3645          /*  sc->args=cons(sc,sc->code,sc->args);*/
3646          putstr(sc,"\nApply to: ");
3647          s_thread_to(sc,OP_P0LIST);
3648        }
3649        /* fall through */
3650      CASE(OP_REAL_APPLY):
3651 #endif
3652 #if USE_HISTORY
3653           if (op != OP_APPLY_CODE)
3654             callsite = sc->code;
3655           if (s_get_flag(sc, TAIL_CONTEXT)) {
3656             /* We are evaluating a tail call.  */
3657             tailstack_push(sc, callsite);
3658           } else {
3659             callstack_push(sc, callsite);
3660             s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
3661           }
3662 #endif
3663
3664           if (is_proc(sc->code)) {
3665                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
3666           } else if (is_foreign(sc->code))
3667             {
3668               /* Keep nested calls from GC'ing the arglist */
3669               push_recent_alloc(sc,sc->args,sc->NIL);
3670                x=sc->code->_object._ff(sc,sc->args);
3671                s_return(sc,x);
3672           } else if (is_closure(sc->code) || is_macro(sc->code)
3673              || is_promise(sc->code)) { /* CLOSURE */
3674         /* Should not accept promise */
3675                /* make environment */
3676                new_frame_in_env(sc, closure_env(sc->code));
3677                for (x = car(closure_code(sc->code)), y = sc->args;
3678                     is_pair(x); x = cdr(x), y = cdr(y)) {
3679                     if (y == sc->NIL) {
3680                          Error_1(sc, "not enough arguments, missing", x);
3681                     } else if (is_symbol(car(x))) {
3682                          new_slot_in_env(sc, car(x), car(y));
3683                     } else {
3684                          Error_1(sc, "syntax error in closure: not a symbol", car(x));
3685                     }
3686                }
3687
3688                if (x == sc->NIL) {
3689                     if (y != sc->NIL) {
3690                       Error_0(sc, "too many arguments");
3691                     }
3692                } else if (is_symbol(x))
3693                     new_slot_in_env(sc, x, y);
3694                else {
3695                     Error_1(sc, "syntax error in closure: not a symbol", x);
3696                }
3697                sc->code = cdr(closure_code(sc->code));
3698                sc->args = sc->NIL;
3699                s_set_flag(sc, TAIL_CONTEXT);
3700                s_thread_to(sc,OP_BEGIN);
3701           } else if (is_continuation(sc->code)) { /* CONTINUATION */
3702                sc->dump = cont_dump(sc->code);
3703                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
3704           } else {
3705                Error_1(sc,"illegal function",sc->code);
3706           }
3707
3708      CASE(OP_DOMACRO):    /* do macro */
3709           sc->code = sc->value;
3710           s_thread_to(sc,OP_EVAL);
3711
3712 #if USE_COMPILE_HOOK
3713      CASE(OP_LAMBDA):     /* lambda */
3714           /* If the hook is defined, apply it to sc->code, otherwise
3715              set sc->value fall through */
3716           {
3717                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
3718                if(f==sc->NIL) {
3719                     sc->value = sc->code;
3720                     /* Fallthru */
3721                } else {
3722                     gc_disable(sc, 1 + gc_reservations (s_save));
3723                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
3724                     sc->args=cons(sc,sc->code,sc->NIL);
3725                     gc_enable(sc);
3726                     sc->code=slot_value_in_env(f);
3727                     s_thread_to(sc,OP_APPLY);
3728                }
3729           }
3730           /* Fallthrough. */
3731 #else
3732      CASE(OP_LAMBDA):     /* lambda */
3733           sc->value = sc->code;
3734           /* Fallthrough. */
3735 #endif
3736
3737      CASE(OP_LAMBDA1):
3738           gc_disable(sc, 1);
3739           s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
3740
3741
3742      CASE(OP_MKCLOSURE): /* make-closure */
3743        x=car(sc->args);
3744        if(car(x)==sc->LAMBDA) {
3745          x=cdr(x);
3746        }
3747        if(cdr(sc->args)==sc->NIL) {
3748          y=sc->envir;
3749        } else {
3750          y=cadr(sc->args);
3751        }
3752        gc_disable(sc, 1);
3753        s_return_enable_gc(sc, mk_closure(sc, x, y));
3754
3755      CASE(OP_QUOTE):      /* quote */
3756           s_return(sc,car(sc->code));
3757
3758      CASE(OP_DEF0):  /* define */
3759           if(is_immutable(car(sc->code)))
3760             Error_1(sc,"define: unable to alter immutable", car(sc->code));
3761
3762           if (is_pair(car(sc->code))) {
3763                x = caar(sc->code);
3764                gc_disable(sc, 2);
3765                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3766                gc_enable(sc);
3767           } else {
3768                x = car(sc->code);
3769                sc->code = cadr(sc->code);
3770           }
3771           if (!is_symbol(x)) {
3772                Error_0(sc,"variable is not a symbol");
3773           }
3774           s_save(sc,OP_DEF1, sc->NIL, x);
3775           s_thread_to(sc,OP_EVAL);
3776
3777      CASE(OP_DEF1): { /* define */
3778           pointer *sslot;
3779           x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
3780           if (x != sc->NIL) {
3781                set_slot_in_env(sc, x, sc->value);
3782           } else {
3783                new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
3784           }
3785           s_return(sc,sc->code);
3786      }
3787
3788      CASE(OP_DEFP):  /* defined? */
3789           x=sc->envir;
3790           if(cdr(sc->args)!=sc->NIL) {
3791                x=cadr(sc->args);
3792           }
3793           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3794
3795      CASE(OP_SET0):       /* set! */
3796           if(is_immutable(car(sc->code)))
3797                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3798           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3799           sc->code = cadr(sc->code);
3800           s_thread_to(sc,OP_EVAL);
3801
3802      CASE(OP_SET1):       /* set! */
3803           y=find_slot_in_env(sc,sc->envir,sc->code,1);
3804           if (y != sc->NIL) {
3805                set_slot_in_env(sc, y, sc->value);
3806                s_return(sc,sc->value);
3807           } else {
3808                Error_1(sc, "set!: unbound variable", sc->code);
3809           }
3810
3811
3812      CASE(OP_BEGIN):      /* begin */
3813           {
3814             int last;
3815
3816             if (!is_pair(sc->code)) {
3817               s_return(sc,sc->code);
3818             }
3819
3820             last = cdr(sc->code) == sc->NIL;
3821             if (!last) {
3822               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3823             }
3824             sc->code = car(sc->code);
3825             if (! last)
3826               /* This is not the end of the list.  This is not a tail
3827                * position.  */
3828               s_clear_flag(sc, TAIL_CONTEXT);
3829             s_thread_to(sc,OP_EVAL);
3830           }
3831
3832      CASE(OP_IF0):        /* if */
3833           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3834           sc->code = car(sc->code);
3835           s_clear_flag(sc, TAIL_CONTEXT);
3836           s_thread_to(sc,OP_EVAL);
3837
3838      CASE(OP_IF1):        /* if */
3839           if (is_true(sc->value))
3840                sc->code = car(sc->code);
3841           else
3842                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
3843                                             * car(sc->NIL) = sc->NIL */
3844           s_thread_to(sc,OP_EVAL);
3845
3846      CASE(OP_LET0):       /* let */
3847           sc->args = sc->NIL;
3848           sc->value = sc->code;
3849           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3850           s_thread_to(sc,OP_LET1);
3851
3852      CASE(OP_LET1):       /* let (calculate parameters) */
3853           gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3854           sc->args = cons(sc, sc->value, sc->args);
3855           if (is_pair(sc->code)) { /* continue */
3856                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3857                     gc_enable(sc);
3858                     Error_1(sc, "Bad syntax of binding spec in let",
3859                             car(sc->code));
3860                }
3861                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
3862                gc_enable(sc);
3863                sc->code = cadar(sc->code);
3864                sc->args = sc->NIL;
3865                s_clear_flag(sc, TAIL_CONTEXT);
3866                s_thread_to(sc,OP_EVAL);
3867           } else {  /* end */
3868                gc_enable(sc);
3869                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3870                sc->code = car(sc->args);
3871                sc->args = cdr(sc->args);
3872                s_thread_to(sc,OP_LET2);
3873           }
3874
3875      CASE(OP_LET2):       /* let */
3876           new_frame_in_env(sc, sc->envir);
3877           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
3878                y != sc->NIL; x = cdr(x), y = cdr(y)) {
3879                new_slot_in_env(sc, caar(x), car(y));
3880           }
3881           if (is_symbol(car(sc->code))) {    /* named let */
3882                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
3883                     if (!is_pair(x))
3884                         Error_1(sc, "Bad syntax of binding in let", x);
3885                     if (!is_list(sc, car(x)))
3886                         Error_1(sc, "Bad syntax of binding in let", car(x));
3887                     gc_disable(sc, 1);
3888                     sc->args = cons(sc, caar(x), sc->args);
3889                     gc_enable(sc);
3890                }
3891                gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
3892                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
3893                new_slot_in_env(sc, car(sc->code), x);
3894                gc_enable(sc);
3895                sc->code = cddr(sc->code);
3896                sc->args = sc->NIL;
3897           } else {
3898                sc->code = cdr(sc->code);
3899                sc->args = sc->NIL;
3900           }
3901           s_thread_to(sc,OP_BEGIN);
3902
3903      CASE(OP_LET0AST):    /* let* */
3904           if (car(sc->code) == sc->NIL) {
3905                new_frame_in_env(sc, sc->envir);
3906                sc->code = cdr(sc->code);
3907                s_thread_to(sc,OP_BEGIN);
3908           }
3909           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
3910                Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code));
3911           }
3912           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
3913           sc->code = cadaar(sc->code);
3914           s_clear_flag(sc, TAIL_CONTEXT);
3915           s_thread_to(sc,OP_EVAL);
3916
3917      CASE(OP_LET1AST):    /* let* (make new frame) */
3918           new_frame_in_env(sc, sc->envir);
3919           s_thread_to(sc,OP_LET2AST);
3920
3921      CASE(OP_LET2AST):    /* let* (calculate parameters) */
3922           new_slot_in_env(sc, caar(sc->code), sc->value);
3923           sc->code = cdr(sc->code);
3924           if (is_pair(sc->code)) { /* continue */
3925                s_save(sc,OP_LET2AST, sc->args, sc->code);
3926                sc->code = cadar(sc->code);
3927                sc->args = sc->NIL;
3928                s_clear_flag(sc, TAIL_CONTEXT);
3929                s_thread_to(sc,OP_EVAL);
3930           } else {  /* end */
3931                sc->code = sc->args;
3932                sc->args = sc->NIL;
3933                s_thread_to(sc,OP_BEGIN);
3934           }
3935
3936      CASE(OP_LET0REC):    /* letrec */
3937           new_frame_in_env(sc, sc->envir);
3938           sc->args = sc->NIL;
3939           sc->value = sc->code;
3940           sc->code = car(sc->code);
3941           s_thread_to(sc,OP_LET1REC);
3942
3943      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
3944           gc_disable(sc, 1);
3945           sc->args = cons(sc, sc->value, sc->args);
3946           gc_enable(sc);
3947           if (is_pair(sc->code)) { /* continue */
3948                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
3949                     Error_1(sc, "Bad syntax of binding spec in letrec",
3950                             car(sc->code));
3951                }
3952                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
3953                sc->code = cadar(sc->code);
3954                sc->args = sc->NIL;
3955                s_clear_flag(sc, TAIL_CONTEXT);
3956                s_thread_to(sc,OP_EVAL);
3957           } else {  /* end */
3958                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3959                sc->code = car(sc->args);
3960                sc->args = cdr(sc->args);
3961                s_thread_to(sc,OP_LET2REC);
3962           }
3963
3964      CASE(OP_LET2REC):    /* letrec */
3965           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
3966                new_slot_in_env(sc, caar(x), car(y));
3967           }
3968           sc->code = cdr(sc->code);
3969           sc->args = sc->NIL;
3970           s_thread_to(sc,OP_BEGIN);
3971
3972      CASE(OP_COND0):      /* cond */
3973           if (!is_pair(sc->code)) {
3974                Error_0(sc,"syntax error in cond");
3975           }
3976           s_save(sc,OP_COND1, sc->NIL, sc->code);
3977           sc->code = caar(sc->code);
3978           s_clear_flag(sc, TAIL_CONTEXT);
3979           s_thread_to(sc,OP_EVAL);
3980
3981      CASE(OP_COND1):      /* cond */
3982           if (is_true(sc->value)) {
3983                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3984                     s_return(sc,sc->value);
3985                }
3986                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3987                     if(!is_pair(cdr(sc->code))) {
3988                          Error_0(sc,"syntax error in cond");
3989                     }
3990                     gc_disable(sc, 4);
3991                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3992                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3993                     gc_enable(sc);
3994                     s_thread_to(sc,OP_EVAL);
3995                }
3996                s_thread_to(sc,OP_BEGIN);
3997           } else {
3998                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3999                     s_return(sc,sc->NIL);
4000                } else {
4001                     s_save(sc,OP_COND1, sc->NIL, sc->code);
4002                     sc->code = caar(sc->code);
4003                     s_clear_flag(sc, TAIL_CONTEXT);
4004                     s_thread_to(sc,OP_EVAL);
4005                }
4006           }
4007
4008      CASE(OP_DELAY):      /* delay */
4009           gc_disable(sc, 2);
4010           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
4011           typeflag(x)=T_PROMISE;
4012           s_return_enable_gc(sc,x);
4013
4014      CASE(OP_AND0):       /* and */
4015           if (sc->code == sc->NIL) {
4016                s_return(sc,sc->T);
4017           }
4018           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
4019           if (cdr(sc->code) != sc->NIL)
4020                s_clear_flag(sc, TAIL_CONTEXT);
4021           sc->code = car(sc->code);
4022           s_thread_to(sc,OP_EVAL);
4023
4024      CASE(OP_AND1):       /* and */
4025           if (is_false(sc->value)) {
4026                s_return(sc,sc->value);
4027           } else if (sc->code == sc->NIL) {
4028                s_return(sc,sc->value);
4029           } else {
4030                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
4031                if (cdr(sc->code) != sc->NIL)
4032                     s_clear_flag(sc, TAIL_CONTEXT);
4033                sc->code = car(sc->code);
4034                s_thread_to(sc,OP_EVAL);
4035           }
4036
4037      CASE(OP_OR0):        /* or */
4038           if (sc->code == sc->NIL) {
4039                s_return(sc,sc->F);
4040           }
4041           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
4042           if (cdr(sc->code) != sc->NIL)
4043                s_clear_flag(sc, TAIL_CONTEXT);
4044           sc->code = car(sc->code);
4045           s_thread_to(sc,OP_EVAL);
4046
4047      CASE(OP_OR1):        /* or */
4048           if (is_true(sc->value)) {
4049                s_return(sc,sc->value);
4050           } else if (sc->code == sc->NIL) {
4051                s_return(sc,sc->value);
4052           } else {
4053                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
4054                if (cdr(sc->code) != sc->NIL)
4055                     s_clear_flag(sc, TAIL_CONTEXT);
4056                sc->code = car(sc->code);
4057                s_thread_to(sc,OP_EVAL);
4058           }
4059
4060      CASE(OP_C0STREAM):   /* cons-stream */
4061           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
4062           sc->code = car(sc->code);
4063           s_thread_to(sc,OP_EVAL);
4064
4065      CASE(OP_C1STREAM):   /* cons-stream */
4066           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
4067           gc_disable(sc, 3);
4068           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
4069           typeflag(x)=T_PROMISE;
4070           s_return_enable_gc(sc, cons(sc, sc->args, x));
4071
4072      CASE(OP_MACRO0):     /* macro */
4073           if (is_pair(car(sc->code))) {
4074                x = caar(sc->code);
4075                gc_disable(sc, 2);
4076                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
4077                gc_enable(sc);
4078           } else {
4079                x = car(sc->code);
4080                sc->code = cadr(sc->code);
4081           }
4082           if (!is_symbol(x)) {
4083                Error_0(sc,"variable is not a symbol");
4084           }
4085           s_save(sc,OP_MACRO1, sc->NIL, x);
4086           s_thread_to(sc,OP_EVAL);
4087
4088      CASE(OP_MACRO1): {   /* macro */
4089           pointer *sslot;
4090           typeflag(sc->value) = T_MACRO;
4091           x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
4092           if (x != sc->NIL) {
4093                set_slot_in_env(sc, x, sc->value);
4094           } else {
4095                new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
4096           }
4097           s_return(sc,sc->code);
4098      }
4099
4100      CASE(OP_CASE0):      /* case */
4101           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
4102           sc->code = car(sc->code);
4103           s_clear_flag(sc, TAIL_CONTEXT);
4104           s_thread_to(sc,OP_EVAL);
4105
4106      CASE(OP_CASE1):      /* case */
4107           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
4108                if (!is_pair(y = caar(x))) {
4109                     break;
4110                }
4111                for ( ; y != sc->NIL; y = cdr(y)) {
4112                     if (eqv(car(y), sc->value)) {
4113                          break;
4114                     }
4115                }
4116                if (y != sc->NIL) {
4117                     break;
4118                }
4119           }
4120           if (x != sc->NIL) {
4121                if (is_pair(caar(x))) {
4122                     sc->code = cdar(x);
4123                     s_thread_to(sc,OP_BEGIN);
4124                } else {/* else */
4125                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
4126                     sc->code = caar(x);
4127                     s_thread_to(sc,OP_EVAL);
4128                }
4129           } else {
4130                s_return(sc,sc->NIL);
4131           }
4132
4133      CASE(OP_CASE2):      /* case */
4134           if (is_true(sc->value)) {
4135                s_thread_to(sc,OP_BEGIN);
4136           } else {
4137                s_return(sc,sc->NIL);
4138           }
4139
4140      CASE(OP_PAPPLY):     /* apply */
4141           sc->code = car(sc->args);
4142           sc->args = list_star(sc,cdr(sc->args));
4143           /*sc->args = cadr(sc->args);*/
4144           s_thread_to(sc,OP_APPLY);
4145
4146      CASE(OP_PEVAL): /* eval */
4147           if(cdr(sc->args)!=sc->NIL) {
4148                sc->envir=cadr(sc->args);
4149           }
4150           sc->code = car(sc->args);
4151           s_thread_to(sc,OP_EVAL);
4152
4153      CASE(OP_CONTINUATION):    /* call-with-current-continuation */
4154           sc->code = car(sc->args);
4155           gc_disable(sc, 2);
4156           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
4157           gc_enable(sc);
4158           s_thread_to(sc,OP_APPLY);
4159
4160 #if USE_MATH
4161      CASE(OP_INEX2EX):    /* inexact->exact */
4162           x=car(sc->args);
4163           if(num_is_integer(x)) {
4164                s_return(sc,x);
4165           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
4166                s_return(sc,mk_integer(sc,ivalue(x)));
4167           } else {
4168                Error_1(sc, "inexact->exact: not integral", x);
4169           }
4170
4171      CASE(OP_EXP):
4172           x=car(sc->args);
4173           s_return(sc, mk_real(sc, exp(rvalue(x))));
4174
4175      CASE(OP_LOG):
4176           x=car(sc->args);
4177           s_return(sc, mk_real(sc, log(rvalue(x))));
4178
4179      CASE(OP_SIN):
4180           x=car(sc->args);
4181           s_return(sc, mk_real(sc, sin(rvalue(x))));
4182
4183      CASE(OP_COS):
4184           x=car(sc->args);
4185           s_return(sc, mk_real(sc, cos(rvalue(x))));
4186
4187      CASE(OP_TAN):
4188           x=car(sc->args);
4189           s_return(sc, mk_real(sc, tan(rvalue(x))));
4190
4191      CASE(OP_ASIN):
4192           x=car(sc->args);
4193           s_return(sc, mk_real(sc, asin(rvalue(x))));
4194
4195      CASE(OP_ACOS):
4196           x=car(sc->args);
4197           s_return(sc, mk_real(sc, acos(rvalue(x))));
4198
4199      CASE(OP_ATAN):
4200           x=car(sc->args);
4201           if(cdr(sc->args)==sc->NIL) {
4202                s_return(sc, mk_real(sc, atan(rvalue(x))));
4203           } else {
4204                pointer y=cadr(sc->args);
4205                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
4206           }
4207
4208      CASE(OP_SQRT):
4209           x=car(sc->args);
4210           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
4211
4212      CASE(OP_EXPT): {
4213           double result;
4214           int real_result=1;
4215           pointer y=cadr(sc->args);
4216           x=car(sc->args);
4217           if (num_is_integer(x) && num_is_integer(y))
4218              real_result=0;
4219           /* This 'if' is an R5RS compatibility fix. */
4220           /* NOTE: Remove this 'if' fix for R6RS.    */
4221           if (rvalue(x) == 0 && rvalue(y) < 0) {
4222              result = 0.0;
4223           } else {
4224              result = pow(rvalue(x),rvalue(y));
4225           }
4226           /* Before returning integer result make sure we can. */
4227           /* If the test fails, result is too big for integer. */
4228           if (!real_result)
4229           {
4230             long result_as_long = (long)result;
4231             if (result != (double)result_as_long)
4232               real_result = 1;
4233           }
4234           if (real_result) {
4235              s_return(sc, mk_real(sc, result));
4236           } else {
4237              s_return(sc, mk_integer(sc, result));
4238           }
4239      }
4240
4241      CASE(OP_FLOOR):
4242           x=car(sc->args);
4243           s_return(sc, mk_real(sc, floor(rvalue(x))));
4244
4245      CASE(OP_CEILING):
4246           x=car(sc->args);
4247           s_return(sc, mk_real(sc, ceil(rvalue(x))));
4248
4249      CASE(OP_TRUNCATE ): {
4250           double rvalue_of_x ;
4251           x=car(sc->args);
4252           rvalue_of_x = rvalue(x) ;
4253           if (rvalue_of_x > 0) {
4254             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
4255           } else {
4256             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
4257           }
4258      }
4259
4260      CASE(OP_ROUND):
4261         x=car(sc->args);
4262         if (num_is_integer(x))
4263             s_return(sc, x);
4264         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
4265 #endif
4266
4267      CASE(OP_ADD):        /* + */
4268        v=num_zero;
4269        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4270          v=num_add(v,nvalue(car(x)));
4271        }
4272        gc_disable(sc, 1);
4273        s_return_enable_gc(sc, mk_number(sc, v));
4274
4275      CASE(OP_MUL):        /* * */
4276        v=num_one;
4277        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4278          v=num_mul(v,nvalue(car(x)));
4279        }
4280        gc_disable(sc, 1);
4281        s_return_enable_gc(sc, mk_number(sc, v));
4282
4283      CASE(OP_SUB):        /* - */
4284        if(cdr(sc->args)==sc->NIL) {
4285          x=sc->args;
4286          v=num_zero;
4287        } else {
4288          x = cdr(sc->args);
4289          v = nvalue(car(sc->args));
4290        }
4291        for (; x != sc->NIL; x = cdr(x)) {
4292          v=num_sub(v,nvalue(car(x)));
4293        }
4294        gc_disable(sc, 1);
4295        s_return_enable_gc(sc, mk_number(sc, v));
4296
4297      CASE(OP_DIV):        /* / */
4298        if(cdr(sc->args)==sc->NIL) {
4299          x=sc->args;
4300          v=num_one;
4301        } else {
4302          x = cdr(sc->args);
4303          v = nvalue(car(sc->args));
4304        }
4305        for (; x != sc->NIL; x = cdr(x)) {
4306          if (!is_zero_double(rvalue(car(x))))
4307            v=num_div(v,nvalue(car(x)));
4308          else {
4309            Error_0(sc,"/: division by zero");
4310          }
4311        }
4312        gc_disable(sc, 1);
4313        s_return_enable_gc(sc, mk_number(sc, v));
4314
4315      CASE(OP_INTDIV):        /* quotient */
4316           if(cdr(sc->args)==sc->NIL) {
4317                x=sc->args;
4318                v=num_one;
4319           } else {
4320                x = cdr(sc->args);
4321                v = nvalue(car(sc->args));
4322           }
4323           for (; x != sc->NIL; x = cdr(x)) {
4324                if (ivalue(car(x)) != 0)
4325                     v=num_intdiv(v,nvalue(car(x)));
4326                else {
4327                     Error_0(sc,"quotient: division by zero");
4328                }
4329           }
4330           gc_disable(sc, 1);
4331           s_return_enable_gc(sc, mk_number(sc, v));
4332
4333      CASE(OP_REM):        /* remainder */
4334           v = nvalue(car(sc->args));
4335           if (ivalue(cadr(sc->args)) != 0)
4336                v=num_rem(v,nvalue(cadr(sc->args)));
4337           else {
4338                Error_0(sc,"remainder: division by zero");
4339           }
4340           gc_disable(sc, 1);
4341           s_return_enable_gc(sc, mk_number(sc, v));
4342
4343      CASE(OP_MOD):        /* modulo */
4344           v = nvalue(car(sc->args));
4345           if (ivalue(cadr(sc->args)) != 0)
4346                v=num_mod(v,nvalue(cadr(sc->args)));
4347           else {
4348                Error_0(sc,"modulo: division by zero");
4349           }
4350           gc_disable(sc, 1);
4351           s_return_enable_gc(sc, mk_number(sc, v));
4352
4353      CASE(OP_CAR):        /* car */
4354           s_return(sc,caar(sc->args));
4355
4356      CASE(OP_CDR):        /* cdr */
4357           s_return(sc,cdar(sc->args));
4358
4359      CASE(OP_CONS):       /* cons */
4360           cdr(sc->args) = cadr(sc->args);
4361           s_return(sc,sc->args);
4362
4363      CASE(OP_SETCAR):     /* set-car! */
4364        if(!is_immutable(car(sc->args))) {
4365          caar(sc->args) = cadr(sc->args);
4366          s_return(sc,car(sc->args));
4367        } else {
4368          Error_0(sc,"set-car!: unable to alter immutable pair");
4369        }
4370
4371      CASE(OP_SETCDR):     /* set-cdr! */
4372        if(!is_immutable(car(sc->args))) {
4373          cdar(sc->args) = cadr(sc->args);
4374          s_return(sc,car(sc->args));
4375        } else {
4376          Error_0(sc,"set-cdr!: unable to alter immutable pair");
4377        }
4378
4379      CASE(OP_CHAR2INT): { /* char->integer */
4380           char c;
4381           c=(char)ivalue(car(sc->args));
4382           gc_disable(sc, 1);
4383           s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
4384      }
4385
4386      CASE(OP_INT2CHAR): { /* integer->char */
4387           unsigned char c;
4388           c=(unsigned char)ivalue(car(sc->args));
4389           gc_disable(sc, 1);
4390           s_return_enable_gc(sc, mk_character(sc, (char) c));
4391      }
4392
4393      CASE(OP_CHARUPCASE): {
4394           unsigned char c;
4395           c=(unsigned char)ivalue(car(sc->args));
4396           c=toupper(c);
4397           gc_disable(sc, 1);
4398           s_return_enable_gc(sc, mk_character(sc, (char) c));
4399      }
4400
4401      CASE(OP_CHARDNCASE): {
4402           unsigned char c;
4403           c=(unsigned char)ivalue(car(sc->args));
4404           c=tolower(c);
4405           gc_disable(sc, 1);
4406           s_return_enable_gc(sc, mk_character(sc, (char) c));
4407      }
4408
4409      CASE(OP_STR2SYM):  /* string->symbol */
4410           gc_disable(sc, gc_reservations (mk_symbol));
4411           s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
4412
4413      CASE(OP_STR2ATOM): /* string->atom */ {
4414           char *s=strvalue(car(sc->args));
4415           long pf = 0;
4416           if(cdr(sc->args)!=sc->NIL) {
4417             /* we know cadr(sc->args) is a natural number */
4418             /* see if it is 2, 8, 10, or 16, or error */
4419             pf = ivalue_unchecked(cadr(sc->args));
4420             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
4421                /* base is OK */
4422             }
4423             else {
4424               pf = -1;
4425             }
4426           }
4427           if (pf < 0) {
4428             Error_1(sc, "string->atom: bad base", cadr(sc->args));
4429           } else if(*s=='#') /* no use of base! */ {
4430             s_return(sc, mk_sharp_const(sc, s+1));
4431           } else {
4432             if (pf == 0 || pf == 10) {
4433               s_return(sc, mk_atom(sc, s));
4434             }
4435             else {
4436               char *ep;
4437               long iv = strtol(s,&ep,(int )pf);
4438               if (*ep == 0) {
4439                 s_return(sc, mk_integer(sc, iv));
4440               }
4441               else {
4442                 s_return(sc, sc->F);
4443               }
4444             }
4445           }
4446         }
4447
4448      CASE(OP_SYM2STR): /* symbol->string */
4449           gc_disable(sc, 1);
4450           x=mk_string(sc,symname(car(sc->args)));
4451           setimmutable(x);
4452           s_return_enable_gc(sc, x);
4453
4454      CASE(OP_ATOM2STR): /* atom->string */ {
4455           long pf = 0;
4456           x=car(sc->args);
4457           if(cdr(sc->args)!=sc->NIL) {
4458             /* we know cadr(sc->args) is a natural number */
4459             /* see if it is 2, 8, 10, or 16, or error */
4460             pf = ivalue_unchecked(cadr(sc->args));
4461             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
4462               /* base is OK */
4463             }
4464             else {
4465               pf = -1;
4466             }
4467           }
4468           if (pf < 0) {
4469             Error_1(sc, "atom->string: bad base", cadr(sc->args));
4470           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
4471             char *p;
4472             int len;
4473             atom2str(sc,x,(int )pf,&p,&len);
4474             gc_disable(sc, 1);
4475             s_return_enable_gc(sc, mk_counted_string(sc, p, len));
4476           } else {
4477             Error_1(sc, "atom->string: not an atom", x);
4478           }
4479         }
4480
4481      CASE(OP_MKSTRING): { /* make-string */
4482           int fill=' ';
4483           int len;
4484
4485           len=ivalue(car(sc->args));
4486
4487           if(cdr(sc->args)!=sc->NIL) {
4488                fill=charvalue(cadr(sc->args));
4489           }
4490           gc_disable(sc, 1);
4491           s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
4492      }
4493
4494      CASE(OP_STRLEN):  /* string-length */
4495           gc_disable(sc, 1);
4496           s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
4497
4498      CASE(OP_STRREF): { /* string-ref */
4499           char *str;
4500           int index;
4501
4502           str=strvalue(car(sc->args));
4503
4504           index=ivalue(cadr(sc->args));
4505
4506           if(index>=strlength(car(sc->args))) {
4507                Error_1(sc, "string-ref: out of bounds", cadr(sc->args));
4508           }
4509
4510           gc_disable(sc, 1);
4511           s_return_enable_gc(sc,
4512                              mk_character(sc, ((unsigned char*) str)[index]));
4513      }
4514
4515      CASE(OP_STRSET): { /* string-set! */
4516           char *str;
4517           int index;
4518           int c;
4519
4520           if(is_immutable(car(sc->args))) {
4521                Error_1(sc, "string-set!: unable to alter immutable string",
4522                        car(sc->args));
4523           }
4524           str=strvalue(car(sc->args));
4525
4526           index=ivalue(cadr(sc->args));
4527           if(index>=strlength(car(sc->args))) {
4528                Error_1(sc, "string-set!: out of bounds", cadr(sc->args));
4529           }
4530
4531           c=charvalue(caddr(sc->args));
4532
4533           str[index]=(char)c;
4534           s_return(sc,car(sc->args));
4535      }
4536
4537      CASE(OP_STRAPPEND): { /* string-append */
4538        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4539        int len = 0;
4540        pointer newstr;
4541        char *pos;
4542
4543        /* compute needed length for new string */
4544        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
4545           len += strlength(car(x));
4546        }
4547        gc_disable(sc, 1);
4548        newstr = mk_empty_string(sc, len, ' ');
4549        /* store the contents of the argument strings into the new string */
4550        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
4551            pos += strlength(car(x)), x = cdr(x)) {
4552            memcpy(pos, strvalue(car(x)), strlength(car(x)));
4553        }
4554        s_return_enable_gc(sc, newstr);
4555      }
4556
4557      CASE(OP_SUBSTR): { /* substring */
4558           char *str;
4559           int index0;
4560           int index1;
4561
4562           str=strvalue(car(sc->args));
4563
4564           index0=ivalue(cadr(sc->args));
4565
4566           if(index0>strlength(car(sc->args))) {
4567                Error_1(sc, "substring: start out of bounds", cadr(sc->args));
4568           }
4569
4570           if(cddr(sc->args)!=sc->NIL) {
4571                index1=ivalue(caddr(sc->args));
4572                if(index1>strlength(car(sc->args)) || index1<index0) {
4573                     Error_1(sc, "substring: end out of bounds", caddr(sc->args));
4574                }
4575           } else {
4576                index1=strlength(car(sc->args));
4577           }
4578
4579           gc_disable(sc, 1);
4580           s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0));
4581      }
4582
4583      CASE(OP_VECTOR): {   /* vector */
4584           int i;
4585           pointer vec;
4586           int len=list_length(sc,sc->args);
4587           if(len<0) {
4588                Error_1(sc, "vector: not a proper list", sc->args);
4589           }
4590           vec=mk_vector(sc,len);
4591           if(sc->no_memory) { s_return(sc, sc->sink); }
4592           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
4593                set_vector_elem(vec,i,car(x));
4594           }
4595           s_return(sc,vec);
4596      }
4597
4598      CASE(OP_MKVECTOR): { /* make-vector */
4599           pointer fill=sc->NIL;
4600           int len;
4601           pointer vec;
4602
4603           len=ivalue(car(sc->args));
4604
4605           if(cdr(sc->args)!=sc->NIL) {
4606                fill=cadr(sc->args);
4607           }
4608           vec=mk_vector(sc,len);
4609           if(sc->no_memory) { s_return(sc, sc->sink); }
4610           if(fill!=sc->NIL) {
4611                fill_vector(vec,fill);
4612           }
4613           s_return(sc,vec);
4614      }
4615
4616      CASE(OP_VECLEN):  /* vector-length */
4617           gc_disable(sc, 1);
4618           s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args))));
4619
4620      CASE(OP_VECREF): { /* vector-ref */
4621           int index;
4622
4623           index=ivalue(cadr(sc->args));
4624
4625           if(index >= vector_length(car(sc->args))) {
4626                Error_1(sc, "vector-ref: out of bounds", cadr(sc->args));
4627           }
4628
4629           s_return(sc,vector_elem(car(sc->args),index));
4630      }
4631
4632      CASE(OP_VECSET): {   /* vector-set! */
4633           int index;
4634
4635           if(is_immutable(car(sc->args))) {
4636                Error_1(sc, "vector-set!: unable to alter immutable vector",
4637                        car(sc->args));
4638           }
4639
4640           index=ivalue(cadr(sc->args));
4641           if(index >= vector_length(car(sc->args))) {
4642                Error_1(sc, "vector-set!: out of bounds", cadr(sc->args));
4643           }
4644
4645           set_vector_elem(car(sc->args),index,caddr(sc->args));
4646           s_return(sc,car(sc->args));
4647      }
4648
4649      CASE(OP_NOT):        /* not */
4650           s_retbool(is_false(car(sc->args)));
4651      CASE(OP_BOOLP):       /* boolean? */
4652           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
4653      CASE(OP_EOFOBJP):       /* boolean? */
4654           s_retbool(car(sc->args) == sc->EOF_OBJ);
4655      CASE(OP_NULLP):       /* null? */
4656           s_retbool(car(sc->args) == sc->NIL);
4657      CASE(OP_NUMEQ):      /* = */
4658           /* Fallthrough.  */
4659      CASE(OP_LESS):       /* < */
4660           /* Fallthrough.  */
4661      CASE(OP_GRE):        /* > */
4662           /* Fallthrough.  */
4663      CASE(OP_LEQ):        /* <= */
4664           /* Fallthrough.  */
4665      CASE(OP_GEQ):        /* >= */
4666           switch(op) {
4667                case OP_NUMEQ: comp_func=num_eq; break;
4668                case OP_LESS:  comp_func=num_lt; break;
4669                case OP_GRE:   comp_func=num_gt; break;
4670                case OP_LEQ:   comp_func=num_le; break;
4671                case OP_GEQ:   comp_func=num_ge; break;
4672                default: assert (! "reached");
4673           }
4674           x=sc->args;
4675           v=nvalue(car(x));
4676           x=cdr(x);
4677
4678           for (; x != sc->NIL; x = cdr(x)) {
4679                if(!comp_func(v,nvalue(car(x)))) {
4680                     s_retbool(0);
4681                }
4682            v=nvalue(car(x));
4683           }
4684           s_retbool(1);
4685      CASE(OP_SYMBOLP):     /* symbol? */
4686           s_retbool(is_symbol(car(sc->args)));
4687      CASE(OP_NUMBERP):     /* number? */
4688           s_retbool(is_number(car(sc->args)));
4689      CASE(OP_STRINGP):     /* string? */
4690           s_retbool(is_string(car(sc->args)));
4691      CASE(OP_INTEGERP):     /* integer? */
4692           s_retbool(is_integer(car(sc->args)));
4693      CASE(OP_REALP):     /* real? */
4694           s_retbool(is_number(car(sc->args))); /* All numbers are real */
4695      CASE(OP_CHARP):     /* char? */
4696           s_retbool(is_character(car(sc->args)));
4697 #if USE_CHAR_CLASSIFIERS
4698      CASE(OP_CHARAP):     /* char-alphabetic? */
4699           s_retbool(Cisalpha(ivalue(car(sc->args))));
4700      CASE(OP_CHARNP):     /* char-numeric? */
4701           s_retbool(Cisdigit(ivalue(car(sc->args))));
4702      CASE(OP_CHARWP):     /* char-whitespace? */
4703           s_retbool(Cisspace(ivalue(car(sc->args))));
4704      CASE(OP_CHARUP):     /* char-upper-case? */
4705           s_retbool(Cisupper(ivalue(car(sc->args))));
4706      CASE(OP_CHARLP):     /* char-lower-case? */
4707           s_retbool(Cislower(ivalue(car(sc->args))));
4708 #endif
4709      CASE(OP_PORTP):     /* port? */
4710           s_retbool(is_port(car(sc->args)));
4711      CASE(OP_INPORTP):     /* input-port? */
4712           s_retbool(is_inport(car(sc->args)));
4713      CASE(OP_OUTPORTP):     /* output-port? */
4714           s_retbool(is_outport(car(sc->args)));
4715      CASE(OP_PROCP):       /* procedure? */
4716           /*--
4717               * continuation should be procedure by the example
4718               * (call-with-current-continuation procedure?) ==> #t
4719                  * in R^3 report sec. 6.9
4720               */
4721           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
4722                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
4723      CASE(OP_PAIRP):       /* pair? */
4724           s_retbool(is_pair(car(sc->args)));
4725      CASE(OP_LISTP):       /* list? */
4726        s_retbool(list_length(sc,car(sc->args)) >= 0);
4727
4728      CASE(OP_ENVP):        /* environment? */
4729           s_retbool(is_environment(car(sc->args)));
4730      CASE(OP_VECTORP):     /* vector? */
4731           s_retbool(is_vector(car(sc->args)));
4732      CASE(OP_EQ):         /* eq? */
4733           s_retbool(car(sc->args) == cadr(sc->args));
4734      CASE(OP_EQV):        /* eqv? */
4735           s_retbool(eqv(car(sc->args), cadr(sc->args)));
4736
4737      CASE(OP_FORCE):      /* force */
4738           sc->code = car(sc->args);
4739           if (is_promise(sc->code)) {
4740                /* Should change type to closure here */
4741                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
4742                sc->args = sc->NIL;
4743                s_thread_to(sc,OP_APPLY);
4744           } else {
4745                s_return(sc,sc->code);
4746           }
4747
4748      CASE(OP_SAVE_FORCED):     /* Save forced value replacing promise */
4749           copy_value(sc, sc->code, sc->value);
4750           s_return(sc,sc->value);
4751
4752      CASE(OP_WRITE):      /* write */
4753           /* Fallthrough.  */
4754      CASE(OP_DISPLAY):    /* display */
4755           /* Fallthrough.  */
4756      CASE(OP_WRITE_CHAR): /* write-char */
4757           if(is_pair(cdr(sc->args))) {
4758                if(cadr(sc->args)!=sc->outport) {
4759                     x=cons(sc,sc->outport,sc->NIL);
4760                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4761                     sc->outport=cadr(sc->args);
4762                }
4763           }
4764           sc->args = car(sc->args);
4765           if(op==OP_WRITE) {
4766                sc->print_flag = 1;
4767           } else {
4768                sc->print_flag = 0;
4769           }
4770           s_thread_to(sc,OP_P0LIST);
4771
4772      CASE(OP_NEWLINE):    /* newline */
4773           if(is_pair(sc->args)) {
4774                if(car(sc->args)!=sc->outport) {
4775                     x=cons(sc,sc->outport,sc->NIL);
4776                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4777                     sc->outport=car(sc->args);
4778                }
4779           }
4780           putstr(sc, "\n");
4781           s_return(sc,sc->T);
4782
4783      CASE(OP_ERR0):  /* error */
4784           sc->retcode=-1;
4785           if (!is_string(car(sc->args))) {
4786                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
4787                setimmutable(car(sc->args));
4788           }
4789           putstr(sc, "Error: ");
4790           putstr(sc, strvalue(car(sc->args)));
4791           sc->args = cdr(sc->args);
4792           s_thread_to(sc,OP_ERR1);
4793
4794      CASE(OP_ERR1):  /* error */
4795           putstr(sc, " ");
4796           if (sc->args != sc->NIL) {
4797                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
4798                sc->args = car(sc->args);
4799                sc->print_flag = 1;
4800                s_thread_to(sc,OP_P0LIST);
4801           } else {
4802                putstr(sc, "\n");
4803                if(sc->interactive_repl) {
4804                     s_thread_to(sc,OP_T0LVL);
4805                } else {
4806                     return;
4807                }
4808           }
4809
4810      CASE(OP_REVERSE):   /* reverse */
4811           s_return(sc,reverse(sc, sc->NIL, car(sc->args)));
4812
4813      CASE(OP_REVERSE_IN_PLACE):   /* reverse! */
4814           s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args)));
4815
4816      CASE(OP_LIST_STAR): /* list* */
4817           s_return(sc,list_star(sc,sc->args));
4818
4819      CASE(OP_APPEND):    /* append */
4820           x = sc->NIL;
4821           y = sc->args;
4822           if (y == x) {
4823               s_return(sc, x);
4824           }
4825
4826           /* cdr() in the while condition is not a typo. If car() */
4827           /* is used (append '() 'a) will return the wrong result.*/
4828           while (cdr(y) != sc->NIL) {
4829               x = revappend(sc, x, car(y));
4830               y = cdr(y);
4831               if (x == sc->F) {
4832                   Error_0(sc, "non-list argument to append");
4833               }
4834           }
4835
4836           s_return(sc, reverse_in_place(sc, car(y), x));
4837
4838 #if USE_PLIST
4839      CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
4840           gc_disable(sc, gc_reservations(set_property));
4841           s_return_enable_gc(sc,
4842                              set_property(sc, car(sc->args),
4843                                           cadr(sc->args), caddr(sc->args)));
4844
4845      CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
4846           s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
4847 #endif /* USE_PLIST */
4848
4849      CASE(OP_TAG_VALUE): {      /* not exposed */
4850           /* This tags sc->value with car(sc->args).  Useful to tag
4851            * results of opcode evaluations.  */
4852           pointer a, b, c;
4853           free_cons(sc, sc->args, &a, &b);
4854           free_cons(sc, b, &b, &c);
4855           assert(c == sc->NIL);
4856           s_return(sc, mk_tagged_value(sc, sc->value, a, b));
4857         }
4858
4859      CASE(OP_MK_TAGGED):        /* make-tagged-value */
4860           if (is_vector(car(sc->args)))
4861                Error_0(sc, "cannot tag vector");
4862           s_return(sc, mk_tagged_value(sc, car(sc->args),
4863                                        car(cadr(sc->args)),
4864                                        cdr(cadr(sc->args))));
4865
4866      CASE(OP_GET_TAG):        /* get-tag */
4867           s_return(sc, get_tag(sc, car(sc->args)));
4868
4869      CASE(OP_QUIT):       /* quit */
4870           if(is_pair(sc->args)) {
4871                sc->retcode=ivalue(car(sc->args));
4872           }
4873           return;
4874
4875      CASE(OP_GC):         /* gc */
4876           gc(sc, sc->NIL, sc->NIL);
4877           s_return(sc,sc->T);
4878
4879      CASE(OP_GCVERB):          /* gc-verbose */
4880      {    int  was = sc->gc_verbose;
4881
4882           sc->gc_verbose = (car(sc->args) != sc->F);
4883           s_retbool(was);
4884      }
4885
4886      CASE(OP_NEWSEGMENT): /* new-segment */
4887           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
4888                Error_0(sc,"new-segment: argument must be a number");
4889           }
4890           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
4891           s_return(sc,sc->T);
4892
4893      CASE(OP_OBLIST): /* oblist */
4894           s_return(sc, oblist_all_symbols(sc));
4895
4896      CASE(OP_CURR_INPORT): /* current-input-port */
4897           s_return(sc,sc->inport);
4898
4899      CASE(OP_CURR_OUTPORT): /* current-output-port */
4900           s_return(sc,sc->outport);
4901
4902      CASE(OP_OPEN_INFILE): /* open-input-file */
4903           /* Fallthrough.  */
4904      CASE(OP_OPEN_OUTFILE): /* open-output-file */
4905           /* Fallthrough.  */
4906      CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
4907           int prop=0;
4908           pointer p;
4909           switch(op) {
4910                case OP_OPEN_INFILE:     prop=port_input; break;
4911                case OP_OPEN_OUTFILE:    prop=port_output; break;
4912                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
4913                default: assert (! "reached");
4914           }
4915           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
4916           if(p==sc->NIL) {
4917                s_return(sc,sc->F);
4918           }
4919           s_return(sc,p);
4920           break;
4921      }
4922
4923 #if USE_STRING_PORTS
4924      CASE(OP_OPEN_INSTRING): /* open-input-string */
4925           /* Fallthrough.  */
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           /* Fallthrough.  */
5007      CASE(OP_PEEK_CHAR): /* peek-char */ {
5008           int c;
5009           if(is_pair(sc->args)) {
5010                if(car(sc->args)!=sc->inport) {
5011                     x=sc->inport;
5012                     x=cons(sc,x,sc->NIL);
5013                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
5014                     sc->inport=car(sc->args);
5015                }
5016           }
5017           c=inchar(sc);
5018           if(c==EOF) {
5019                s_return(sc,sc->EOF_OBJ);
5020           }
5021           if(op==OP_PEEK_CHAR) {
5022                backchar(sc,c);
5023           }
5024           s_return(sc,mk_character(sc,c));
5025      }
5026
5027      CASE(OP_CHAR_READY): /* char-ready? */ {
5028           pointer p=sc->inport;
5029           int res;
5030           if(is_pair(sc->args)) {
5031                p=car(sc->args);
5032           }
5033           res=p->_object._port->kind&port_string;
5034           s_retbool(res);
5035      }
5036
5037      CASE(OP_SET_INPORT): /* set-input-port */
5038           sc->inport=car(sc->args);
5039           s_return(sc,sc->value);
5040
5041      CASE(OP_SET_OUTPORT): /* set-output-port */
5042           sc->outport=car(sc->args);
5043           s_return(sc,sc->value);
5044
5045      CASE(OP_RDSEXPR):
5046           switch (sc->tok) {
5047           case TOK_EOF:
5048                s_return(sc,sc->EOF_OBJ);
5049           /* NOTREACHED */
5050           case TOK_VEC:
5051                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
5052                /* fall through */
5053           case TOK_LPAREN:
5054                sc->tok = token(sc);
5055                if (sc->tok == TOK_RPAREN) {
5056                     s_return(sc,sc->NIL);
5057                } else if (sc->tok == TOK_DOT) {
5058                     Error_0(sc,"syntax error: illegal dot expression");
5059                } else {
5060 #if SHOW_ERROR_LINE
5061                     pointer filename;
5062                     pointer lineno;
5063 #endif
5064                     sc->nesting_stack[sc->file_i]++;
5065 #if SHOW_ERROR_LINE
5066                     filename = sc->load_stack[sc->file_i].filename;
5067                     lineno = sc->load_stack[sc->file_i].curr_line;
5068
5069                     s_save(sc, OP_TAG_VALUE,
5070                            cons(sc, filename, cons(sc, lineno, sc->NIL)),
5071                            sc->NIL);
5072 #endif
5073                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
5074                     s_thread_to(sc,OP_RDSEXPR);
5075                }
5076           case TOK_QUOTE:
5077                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
5078                sc->tok = token(sc);
5079                s_thread_to(sc,OP_RDSEXPR);
5080           case TOK_BQUOTE:
5081                sc->tok = token(sc);
5082                if(sc->tok==TOK_VEC) {
5083                  s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
5084                  sc->tok=TOK_LPAREN;
5085                  s_thread_to(sc,OP_RDSEXPR);
5086                } else {
5087                  s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
5088                }
5089                s_thread_to(sc,OP_RDSEXPR);
5090           case TOK_COMMA:
5091                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
5092                sc->tok = token(sc);
5093                s_thread_to(sc,OP_RDSEXPR);
5094           case TOK_ATMARK:
5095                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
5096                sc->tok = token(sc);
5097                s_thread_to(sc,OP_RDSEXPR);
5098           case TOK_ATOM:
5099                s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
5100           case TOK_DQUOTE:
5101                x=readstrexp(sc);
5102                if(x==sc->F) {
5103                  Error_0(sc,"Error reading string");
5104                }
5105                setimmutable(x);
5106                s_return(sc,x);
5107           case TOK_SHARP: {
5108                pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
5109                if(f==sc->NIL) {
5110                     Error_0(sc,"undefined sharp expression");
5111                } else {
5112                     sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
5113                     s_thread_to(sc,OP_EVAL);
5114                }
5115           }
5116           case TOK_SHARP_CONST:
5117                if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
5118                     Error_0(sc,"undefined sharp expression");
5119                } else {
5120                     s_return(sc,x);
5121                }
5122           default:
5123                Error_0(sc,"syntax error: illegal token");
5124           }
5125           break;
5126
5127      CASE(OP_RDLIST): {
5128           gc_disable(sc, 1);
5129           sc->args = cons(sc, sc->value, sc->args);
5130           gc_enable(sc);
5131           sc->tok = token(sc);
5132           if (sc->tok == TOK_EOF)
5133                { s_return(sc,sc->EOF_OBJ); }
5134           else if (sc->tok == TOK_RPAREN) {
5135                int c = inchar(sc);
5136                if (c != '\n')
5137                  backchar(sc,c);
5138                else
5139                  port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
5140                sc->nesting_stack[sc->file_i]--;
5141                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
5142           } else if (sc->tok == TOK_DOT) {
5143                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
5144                sc->tok = token(sc);
5145                s_thread_to(sc,OP_RDSEXPR);
5146           } else {
5147                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
5148                s_thread_to(sc,OP_RDSEXPR);
5149           }
5150      }
5151
5152      CASE(OP_RDDOT):
5153           if (token(sc) != TOK_RPAREN) {
5154                Error_0(sc,"syntax error: illegal dot expression");
5155           } else {
5156                sc->nesting_stack[sc->file_i]--;
5157                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
5158           }
5159
5160      CASE(OP_RDQUOTE):
5161           gc_disable(sc, 2);
5162           s_return_enable_gc(sc, cons(sc, sc->QUOTE,
5163                                       cons(sc, sc->value, sc->NIL)));
5164
5165      CASE(OP_RDQQUOTE):
5166           gc_disable(sc, 2);
5167           s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
5168                                       cons(sc, sc->value, sc->NIL)));
5169
5170      CASE(OP_RDQQUOTEVEC):
5171           gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
5172           s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
5173            cons(sc, mk_symbol(sc,"vector"),
5174                  cons(sc,cons(sc, sc->QQUOTE,
5175                   cons(sc,sc->value,sc->NIL)),
5176                   sc->NIL))));
5177
5178      CASE(OP_RDUNQUOTE):
5179           gc_disable(sc, 2);
5180           s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
5181                                       cons(sc, sc->value, sc->NIL)));
5182
5183      CASE(OP_RDUQTSP):
5184           gc_disable(sc, 2);
5185           s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
5186                                       cons(sc, sc->value, sc->NIL)));
5187
5188      CASE(OP_RDVEC):
5189           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
5190           s_thread_to(sc,OP_EVAL); Cannot be quoted*/
5191           /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
5192           s_return(sc,x); Cannot be part of pairs*/
5193           /*sc->code=mk_proc(sc,OP_VECTOR);
5194           sc->args=sc->value;
5195           s_thread_to(sc,OP_APPLY);*/
5196           sc->args=sc->value;
5197           s_thread_to(sc,OP_VECTOR);
5198
5199      /* ========== printing part ========== */
5200      CASE(OP_P0LIST):
5201           if(is_vector(sc->args)) {
5202                putstr(sc,"#(");
5203                sc->args=cons(sc,sc->args,mk_integer(sc,0));
5204                s_thread_to(sc,OP_PVECFROM);
5205           } else if(is_environment(sc->args)) {
5206                putstr(sc,"#<ENVIRONMENT>");
5207                s_return(sc,sc->T);
5208           } else if (!is_pair(sc->args)) {
5209                printatom(sc, sc->args, sc->print_flag);
5210                s_return(sc,sc->T);
5211           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
5212                putstr(sc, "'");
5213                sc->args = cadr(sc->args);
5214                s_thread_to(sc,OP_P0LIST);
5215           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
5216                putstr(sc, "`");
5217                sc->args = cadr(sc->args);
5218                s_thread_to(sc,OP_P0LIST);
5219           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
5220                putstr(sc, ",");
5221                sc->args = cadr(sc->args);
5222                s_thread_to(sc,OP_P0LIST);
5223           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
5224                putstr(sc, ",@");
5225                sc->args = cadr(sc->args);
5226                s_thread_to(sc,OP_P0LIST);
5227           } else {
5228                putstr(sc, "(");
5229                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5230                sc->args = car(sc->args);
5231                s_thread_to(sc,OP_P0LIST);
5232           }
5233
5234      CASE(OP_P1LIST):
5235           if (is_pair(sc->args)) {
5236             s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
5237             putstr(sc, " ");
5238             sc->args = car(sc->args);
5239             s_thread_to(sc,OP_P0LIST);
5240           } else if(is_vector(sc->args)) {
5241             s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
5242             putstr(sc, " . ");
5243             s_thread_to(sc,OP_P0LIST);
5244           } else {
5245             if (sc->args != sc->NIL) {
5246               putstr(sc, " . ");
5247               printatom(sc, sc->args, sc->print_flag);
5248             }
5249             putstr(sc, ")");
5250             s_return(sc,sc->T);
5251           }
5252      CASE(OP_PVECFROM): {
5253           int i=ivalue_unchecked(cdr(sc->args));
5254           pointer vec=car(sc->args);
5255           int len = vector_length(vec);
5256           if(i==len) {
5257                putstr(sc,")");
5258                s_return(sc,sc->T);
5259           } else {
5260                pointer elem=vector_elem(vec,i);
5261                cdr(sc->args) = mk_integer(sc, i + 1);
5262                s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
5263                sc->args=elem;
5264                if (i > 0)
5265                    putstr(sc," ");
5266                s_thread_to(sc,OP_P0LIST);
5267           }
5268      }
5269
5270      CASE(OP_LIST_LENGTH): {   /* length */   /* a.k */
5271           long l = list_length(sc, car(sc->args));
5272           if(l<0) {
5273                Error_1(sc, "length: not a list", car(sc->args));
5274           }
5275           gc_disable(sc, 1);
5276           s_return_enable_gc(sc, mk_integer(sc, l));
5277      }
5278      CASE(OP_ASSQ):       /* assq */     /* a.k */
5279           x = car(sc->args);
5280           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
5281                if (!is_pair(car(y))) {
5282                     Error_0(sc,"unable to handle non pair element");
5283                }
5284                if (x == caar(y))
5285                     break;
5286           }
5287           if (is_pair(y)) {
5288                s_return(sc,car(y));
5289           } else {
5290                s_return(sc,sc->F);
5291           }
5292
5293
5294      CASE(OP_GET_CLOSURE):     /* get-closure-code */   /* a.k */
5295           sc->args = car(sc->args);
5296           if (sc->args == sc->NIL) {
5297                s_return(sc,sc->F);
5298           } else if (is_closure(sc->args)) {
5299                gc_disable(sc, 1);
5300                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5301                                            closure_code(sc->value)));
5302           } else if (is_macro(sc->args)) {
5303                gc_disable(sc, 1);
5304                s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
5305                                            closure_code(sc->value)));
5306           } else {
5307                s_return(sc,sc->F);
5308           }
5309      CASE(OP_CLOSUREP):        /* closure? */
5310           /*
5311            * Note, macro object is also a closure.
5312            * Therefore, (closure? <#MACRO>) ==> #t
5313            */
5314           s_retbool(is_closure(car(sc->args)));
5315      CASE(OP_MACROP):          /* macro? */
5316           s_retbool(is_macro(car(sc->args)));
5317      CASE(OP_VM_HISTORY):          /* *vm-history* */
5318           s_return(sc, history_flatten(sc));
5319      default:
5320           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op);
5321           Error_0(sc,sc->strbuff);
5322      }
5323   }
5324 }
5325
5326 typedef int (*test_predicate)(pointer);
5327
5328 static int is_any(pointer p) {
5329    (void)p;
5330    return 1;
5331 }
5332
5333 static int is_nonneg(pointer p) {
5334   return ivalue(p)>=0 && is_integer(p);
5335 }
5336
5337 /* Correspond carefully with following defines! */
5338 static const struct {
5339   test_predicate fct;
5340   const char *kind;
5341 } tests[]={
5342   {0,0}, /* unused */
5343   {is_any, 0},
5344   {is_string, "string"},
5345   {is_symbol, "symbol"},
5346   {is_port, "port"},
5347   {is_inport,"input port"},
5348   {is_outport,"output port"},
5349   {is_environment, "environment"},
5350   {is_pair, "pair"},
5351   {0, "pair or '()"},
5352   {is_character, "character"},
5353   {is_vector, "vector"},
5354   {is_number, "number"},
5355   {is_integer, "integer"},
5356   {is_nonneg, "non-negative integer"}
5357 };
5358
5359 #define TST_NONE 0
5360 #define TST_ANY "\001"
5361 #define TST_STRING "\002"
5362 #define TST_SYMBOL "\003"
5363 #define TST_PORT "\004"
5364 #define TST_INPORT "\005"
5365 #define TST_OUTPORT "\006"
5366 #define TST_ENVIRONMENT "\007"
5367 #define TST_PAIR "\010"
5368 #define TST_LIST "\011"
5369 #define TST_CHAR "\012"
5370 #define TST_VECTOR "\013"
5371 #define TST_NUMBER "\014"
5372 #define TST_INTEGER "\015"
5373 #define TST_NATURAL "\016"
5374
5375 #define INF_ARG 0xff
5376
5377 static const struct op_code_info dispatch_table[]= {
5378 #define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}},
5379 #include "opdefines.h"
5380 #undef _OP_DEF
5381   {{0},0,0,{0}},
5382 };
5383
5384 static const char *procname(pointer x) {
5385  int n=procnum(x);
5386  const char *name=dispatch_table[n].name;
5387  if (name[0] == 0) {
5388      name="ILLEGAL!";
5389  }
5390  return name;
5391 }
5392
5393 static int
5394 check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size)
5395 {
5396   int ok = 1;
5397   int n = list_length(sc, sc->args);
5398
5399   /* Check number of arguments */
5400   if (n < pcd->min_arity) {
5401     ok = 0;
5402     snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
5403              pcd->name,
5404              pcd->min_arity == pcd->max_arity ? "" : " at least",
5405              pcd->min_arity);
5406   }
5407   if (ok && n>pcd->max_arity) {
5408     ok = 0;
5409     snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
5410              pcd->name,
5411              pcd->min_arity == pcd->max_arity ? "" : " at most",
5412              pcd->max_arity);
5413   }
5414   if (ok) {
5415     if (pcd->arg_tests_encoding[0] != 0) {
5416       int i = 0;
5417       int j;
5418       const char *t = pcd->arg_tests_encoding;
5419       pointer arglist = sc->args;
5420
5421       do {
5422         pointer arg = car(arglist);
5423         j = (int)t[0];
5424         if (j == TST_LIST[0]) {
5425           if (arg != sc->NIL && !is_pair(arg)) break;
5426         } else {
5427           if (!tests[j].fct(arg)) break;
5428         }
5429
5430         if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) {
5431           /* last test is replicated as necessary */
5432           t++;
5433         }
5434         arglist = cdr(arglist);
5435         i++;
5436       } while (i < n);
5437
5438       if (i < n) {
5439         ok = 0;
5440         snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s",
5441                  pcd->name,
5442                  i + 1,
5443                  tests[j].kind,
5444                  type_to_string(type(car(arglist))));
5445       }
5446     }
5447   }
5448
5449   return ok;
5450 }
5451
5452 /* ========== Initialization of internal keywords ========== */
5453
5454 /* Symbols representing syntax are tagged with (OP . '()).  */
5455 static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) {
5456      pointer x, y;
5457      pointer *slot;
5458
5459      x = oblist_find_by_name(sc, name, &slot);
5460      assert (x == sc->NIL);
5461
5462      x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
5463      typeflag(x) = T_SYMBOL | T_SYNTAX;
5464      setimmutable(car(x));
5465      y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL);
5466      free_cell(sc, x);
5467      setimmutable(get_tag(sc, y));
5468      *slot = immutable_cons(sc, y, *slot);
5469 }
5470
5471 /* Returns the opcode for the syntax represented by P.  */
5472 static int syntaxnum(scheme *sc, pointer p) {
5473   int op = ivalue_unchecked(car(get_tag(sc, p)));
5474   assert (op < OP_MAXDEFINED);
5475   return op;
5476 }
5477
5478 static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) {
5479      pointer x, y;
5480
5481      x = mk_symbol(sc, name);
5482      y = mk_proc(sc,op);
5483      new_slot_in_env(sc, x, y);
5484 }
5485
5486 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
5487      pointer y;
5488
5489      y = get_cell(sc, sc->NIL, sc->NIL);
5490      typeflag(y) = (T_PROC | T_ATOM);
5491      ivalue_unchecked(y) = (long) op;
5492      set_num_integer(y);
5493      return y;
5494 }
5495
5496 /* initialization of TinyScheme */
5497 #if USE_INTERFACE
5498 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
5499  return cons(sc,a,b);
5500 }
5501 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
5502  return immutable_cons(sc,a,b);
5503 }
5504
5505 static const struct scheme_interface vtbl = {
5506   scheme_define,
5507   s_cons,
5508   s_immutable_cons,
5509   reserve_cells,
5510   mk_integer,
5511   mk_real,
5512   mk_symbol,
5513   gensym,
5514   mk_string,
5515   mk_counted_string,
5516   mk_character,
5517   mk_vector,
5518   mk_foreign_func,
5519   mk_foreign_object,
5520   get_foreign_object_vtable,
5521   get_foreign_object_data,
5522   putstr,
5523   putcharacter,
5524
5525   is_string,
5526   string_value,
5527   is_number,
5528   nvalue,
5529   ivalue,
5530   rvalue,
5531   is_integer,
5532   is_real,
5533   is_character,
5534   charvalue,
5535   is_list,
5536   is_vector,
5537   list_length,
5538   ivalue,
5539   fill_vector,
5540   vector_elem,
5541   set_vector_elem,
5542   is_port,
5543   is_pair,
5544   pair_car,
5545   pair_cdr,
5546   set_car,
5547   set_cdr,
5548
5549   is_symbol,
5550   symname,
5551
5552   is_syntax,
5553   is_proc,
5554   is_foreign,
5555   syntaxname,
5556   is_closure,
5557   is_macro,
5558   closure_code,
5559   closure_env,
5560
5561   is_continuation,
5562   is_promise,
5563   is_environment,
5564   is_immutable,
5565   setimmutable,
5566
5567   scheme_load_file,
5568   scheme_load_string,
5569   port_from_file
5570 };
5571 #endif
5572
5573 scheme *scheme_init_new() {
5574   scheme *sc=(scheme*)malloc(sizeof(scheme));
5575   if(!scheme_init(sc)) {
5576     free(sc);
5577     return 0;
5578   } else {
5579     return sc;
5580   }
5581 }
5582
5583 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
5584   scheme *sc=(scheme*)malloc(sizeof(scheme));
5585   if(!scheme_init_custom_alloc(sc,malloc,free)) {
5586     free(sc);
5587     return 0;
5588   } else {
5589     return sc;
5590   }
5591 }
5592
5593
5594 int scheme_init(scheme *sc) {
5595  return scheme_init_custom_alloc(sc,malloc,free);
5596 }
5597
5598 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
5599   int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
5600   pointer x;
5601
5602 #if USE_INTERFACE
5603   sc->vptr=&vtbl;
5604 #endif
5605   sc->gensym_cnt=0;
5606   sc->malloc=malloc;
5607   sc->free=free;
5608   sc->sink = &sc->_sink;
5609   sc->NIL = &sc->_NIL;
5610   sc->T = &sc->_HASHT;
5611   sc->F = &sc->_HASHF;
5612   sc->EOF_OBJ=&sc->_EOF_OBJ;
5613
5614   sc->free_cell = &sc->_NIL;
5615   sc->fcells = 0;
5616   sc->inhibit_gc = GC_ENABLED;
5617   sc->reserved_cells = 0;
5618   sc->reserved_lineno = 0;
5619   sc->no_memory=0;
5620   sc->inport=sc->NIL;
5621   sc->outport=sc->NIL;
5622   sc->save_inport=sc->NIL;
5623   sc->loadport=sc->NIL;
5624   sc->nesting=0;
5625   memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
5626   sc->interactive_repl=0;
5627   sc->strbuff = sc->malloc(STRBUFFSIZE);
5628   if (sc->strbuff == 0) {
5629      sc->no_memory=1;
5630      return 0;
5631   }
5632   sc->strbuff_size = STRBUFFSIZE;
5633
5634   sc->cell_segments = NULL;
5635   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
5636     sc->no_memory=1;
5637     return 0;
5638   }
5639   sc->gc_verbose = 0;
5640   dump_stack_initialize(sc);
5641   sc->code = sc->NIL;
5642   sc->tracing=0;
5643   sc->flags = 0;
5644
5645   /* init sc->NIL */
5646   typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
5647   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
5648   /* init T */
5649   typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
5650   car(sc->T) = cdr(sc->T) = sc->T;
5651   /* init F */
5652   typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
5653   car(sc->F) = cdr(sc->F) = sc->F;
5654   /* init EOF_OBJ */
5655   typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
5656   car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
5657   /* init sink */
5658   typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
5659   car(sc->sink) = cdr(sc->sink) = sc->NIL;
5660   /* init c_nest */
5661   sc->c_nest = sc->NIL;
5662
5663   sc->oblist = oblist_initial_value(sc);
5664   /* init global_env */
5665   new_frame_in_env(sc, sc->NIL);
5666   sc->global_env = sc->envir;
5667   /* init else */
5668   x = mk_symbol(sc,"else");
5669   new_slot_in_env(sc, x, sc->T);
5670
5671   assign_syntax(sc, OP_LAMBDA, "lambda");
5672   assign_syntax(sc, OP_QUOTE, "quote");
5673   assign_syntax(sc, OP_DEF0, "define");
5674   assign_syntax(sc, OP_IF0, "if");
5675   assign_syntax(sc, OP_BEGIN, "begin");
5676   assign_syntax(sc, OP_SET0, "set!");
5677   assign_syntax(sc, OP_LET0, "let");
5678   assign_syntax(sc, OP_LET0AST, "let*");
5679   assign_syntax(sc, OP_LET0REC, "letrec");
5680   assign_syntax(sc, OP_COND0, "cond");
5681   assign_syntax(sc, OP_DELAY, "delay");
5682   assign_syntax(sc, OP_AND0, "and");
5683   assign_syntax(sc, OP_OR0, "or");
5684   assign_syntax(sc, OP_C0STREAM, "cons-stream");
5685   assign_syntax(sc, OP_MACRO0, "macro");
5686   assign_syntax(sc, OP_CASE0, "case");
5687
5688   for(i=0; i<n; i++) {
5689     if (dispatch_table[i].name[0] != 0) {
5690       assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
5691     }
5692   }
5693
5694   history_init(sc, 8, 8);
5695
5696   /* initialization of global pointers to special symbols */
5697   sc->LAMBDA = mk_symbol(sc, "lambda");
5698   sc->QUOTE = mk_symbol(sc, "quote");
5699   sc->QQUOTE = mk_symbol(sc, "quasiquote");
5700   sc->UNQUOTE = mk_symbol(sc, "unquote");
5701   sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
5702   sc->FEED_TO = mk_symbol(sc, "=>");
5703   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
5704   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
5705   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
5706 #if USE_COMPILE_HOOK
5707   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
5708 #endif
5709
5710   return !sc->no_memory;
5711 }
5712
5713 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
5714   sc->inport=port_from_file(sc,fin,port_input);
5715 }
5716
5717 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
5718   sc->inport=port_from_string(sc,start,past_the_end,port_input);
5719 }
5720
5721 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
5722   sc->outport=port_from_file(sc,fout,port_output);
5723 }
5724
5725 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
5726   sc->outport=port_from_string(sc,start,past_the_end,port_output);
5727 }
5728
5729 void scheme_set_external_data(scheme *sc, void *p) {
5730  sc->ext_data=p;
5731 }
5732
5733 void scheme_deinit(scheme *sc) {
5734   struct cell_segment *s;
5735   int i;
5736
5737   sc->oblist=sc->NIL;
5738   sc->global_env=sc->NIL;
5739   dump_stack_free(sc);
5740   sc->envir=sc->NIL;
5741   sc->code=sc->NIL;
5742   history_free(sc);
5743   sc->args=sc->NIL;
5744   sc->value=sc->NIL;
5745   if(is_port(sc->inport)) {
5746     typeflag(sc->inport) = T_ATOM;
5747   }
5748   sc->inport=sc->NIL;
5749   sc->outport=sc->NIL;
5750   if(is_port(sc->save_inport)) {
5751     typeflag(sc->save_inport) = T_ATOM;
5752   }
5753   sc->save_inport=sc->NIL;
5754   if(is_port(sc->loadport)) {
5755     typeflag(sc->loadport) = T_ATOM;
5756   }
5757   sc->loadport=sc->NIL;
5758
5759   for(i=0; i<=sc->file_i; i++) {
5760     port_clear_location(sc, &sc->load_stack[i]);
5761   }
5762
5763   sc->gc_verbose=0;
5764   gc(sc,sc->NIL,sc->NIL);
5765
5766   for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) {
5767     /* nop */
5768   }
5769   sc->free(sc->strbuff);
5770 }
5771
5772 void scheme_load_file(scheme *sc, FILE *fin)
5773 { scheme_load_named_file(sc,fin,0); }
5774
5775 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
5776   dump_stack_reset(sc);
5777   sc->envir = sc->global_env;
5778   sc->file_i=0;
5779   sc->load_stack[0].kind=port_input|port_file;
5780   sc->load_stack[0].rep.stdio.file=fin;
5781   sc->loadport=mk_port(sc,sc->load_stack);
5782   sc->retcode=0;
5783   if(fin==stdin) {
5784     sc->interactive_repl=1;
5785   }
5786
5787   port_init_location(sc, &sc->load_stack[0],
5788                      (fin != stdin && filename)
5789                      ? mk_string(sc, filename)
5790                      : NULL);
5791
5792   sc->inport=sc->loadport;
5793   sc->args = mk_integer(sc,sc->file_i);
5794   Eval_Cycle(sc, OP_T0LVL);
5795   typeflag(sc->loadport)=T_ATOM;
5796   if(sc->retcode==0) {
5797     sc->retcode=sc->nesting!=0;
5798   }
5799
5800   port_clear_location(sc, &sc->load_stack[0]);
5801 }
5802
5803 void scheme_load_string(scheme *sc, const char *cmd) {
5804   scheme_load_memory(sc, cmd, strlen(cmd), NULL);
5805 }
5806
5807 void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) {
5808   dump_stack_reset(sc);
5809   sc->envir = sc->global_env;
5810   sc->file_i=0;
5811   sc->load_stack[0].kind=port_input|port_string;
5812   sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */
5813   sc->load_stack[0].rep.string.past_the_end = (char *) buf + len;
5814   sc->load_stack[0].rep.string.curr = (char *) buf;
5815   port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL);
5816   sc->loadport=mk_port(sc,sc->load_stack);
5817   sc->retcode=0;
5818   sc->interactive_repl=0;
5819   sc->inport=sc->loadport;
5820   sc->args = mk_integer(sc,sc->file_i);
5821   Eval_Cycle(sc, OP_T0LVL);
5822   typeflag(sc->loadport)=T_ATOM;
5823   if(sc->retcode==0) {
5824     sc->retcode=sc->nesting!=0;
5825   }
5826
5827   port_clear_location(sc, &sc->load_stack[0]);
5828 }
5829
5830 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
5831      pointer x;
5832      pointer *sslot;
5833      x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot);
5834      if (x != sc->NIL) {
5835           set_slot_in_env(sc, x, value);
5836      } else {
5837           new_slot_spec_in_env(sc, symbol, value, sslot);
5838      }
5839 }
5840
5841 #if !STANDALONE
5842 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
5843 {
5844   scheme_define(sc,
5845                 sc->global_env,
5846                 mk_symbol(sc,sr->name),
5847                 mk_foreign_func(sc, sr->f));
5848 }
5849
5850 void scheme_register_foreign_func_list(scheme * sc,
5851                                        scheme_registerable * list,
5852                                        int count)
5853 {
5854   int i;
5855   for(i = 0; i < count; i++)
5856     {
5857       scheme_register_foreign_func(sc, list + i);
5858     }
5859 }
5860
5861 pointer scheme_apply0(scheme *sc, const char *procname)
5862 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
5863
5864 void save_from_C_call(scheme *sc)
5865 {
5866   pointer saved_data =
5867     cons(sc,
5868          car(sc->sink),
5869          cons(sc,
5870               sc->envir,
5871               sc->dump));
5872   /* Push */
5873   sc->c_nest = cons(sc, saved_data, sc->c_nest);
5874   /* Truncate the dump stack so TS will return here when done, not
5875      directly resume pre-C-call operations. */
5876   dump_stack_reset(sc);
5877 }
5878 void restore_from_C_call(scheme *sc)
5879 {
5880   car(sc->sink) = caar(sc->c_nest);
5881   sc->envir = cadar(sc->c_nest);
5882   sc->dump = cdr(cdar(sc->c_nest));
5883   /* Pop */
5884   sc->c_nest = cdr(sc->c_nest);
5885 }
5886
5887 /* "func" and "args" are assumed to be already eval'ed. */
5888 pointer scheme_call(scheme *sc, pointer func, pointer args)
5889 {
5890   int old_repl = sc->interactive_repl;
5891   sc->interactive_repl = 0;
5892   save_from_C_call(sc);
5893   sc->envir = sc->global_env;
5894   sc->args = args;
5895   sc->code = func;
5896   sc->retcode = 0;
5897   Eval_Cycle(sc, OP_APPLY);
5898   sc->interactive_repl = old_repl;
5899   restore_from_C_call(sc);
5900   return sc->value;
5901 }
5902
5903 pointer scheme_eval(scheme *sc, pointer obj)
5904 {
5905   int old_repl = sc->interactive_repl;
5906   sc->interactive_repl = 0;
5907   save_from_C_call(sc);
5908   sc->args = sc->NIL;
5909   sc->code = obj;
5910   sc->retcode = 0;
5911   Eval_Cycle(sc, OP_EVAL);
5912   sc->interactive_repl = old_repl;
5913   restore_from_C_call(sc);
5914   return sc->value;
5915 }
5916
5917
5918 #endif
5919
5920 /* ========== Main ========== */
5921
5922 #if STANDALONE
5923
5924 #if defined(__APPLE__) && !defined (OSX)
5925 int main()
5926 {
5927      extern MacTS_main(int argc, char **argv);
5928      char**    argv;
5929      int argc = ccommand(&argv);
5930      MacTS_main(argc,argv);
5931      return 0;
5932 }
5933 int MacTS_main(int argc, char **argv) {
5934 #else
5935 int main(int argc, char **argv) {
5936 #endif
5937   scheme sc;
5938   FILE *fin;
5939   char *file_name=InitFile;
5940   int retcode;
5941   int isfile=1;
5942
5943   if(argc==1) {
5944     printf(banner);
5945   }
5946   if(argc==2 && strcmp(argv[1],"-?")==0) {
5947     printf("Usage: tinyscheme -?\n");
5948     printf("or:    tinyscheme [<file1> <file2> ...]\n");
5949     printf("followed by\n");
5950     printf("          -1 <file> [<arg1> <arg2> ...]\n");
5951     printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
5952     printf("assuming that the executable is named tinyscheme.\n");
5953     printf("Use - as filename for stdin.\n");
5954     return 1;
5955   }
5956   if(!scheme_init(&sc)) {
5957     fprintf(stderr,"Could not initialize!\n");
5958     return 2;
5959   }
5960   scheme_set_input_port_file(&sc, stdin);
5961   scheme_set_output_port_file(&sc, stdout);
5962 #if USE_DL
5963   scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
5964 #endif
5965   argv++;
5966   if(access(file_name,0)!=0) {
5967     char *p=getenv("TINYSCHEMEINIT");
5968     if(p!=0) {
5969       file_name=p;
5970     }
5971   }
5972   do {
5973     if(strcmp(file_name,"-")==0) {
5974       fin=stdin;
5975     } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
5976       pointer args=sc.NIL;
5977       isfile=file_name[1]=='1';
5978       file_name=*argv++;
5979       if(strcmp(file_name,"-")==0) {
5980         fin=stdin;
5981       } else if(isfile) {
5982         fin=fopen(file_name,"r");
5983       }
5984       for(;*argv;argv++) {
5985         pointer value=mk_string(&sc,*argv);
5986         args=cons(&sc,value,args);
5987       }
5988       args=reverse_in_place(&sc,sc.NIL,args);
5989       scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
5990
5991     } else {
5992       fin=fopen(file_name,"r");
5993     }
5994     if(isfile && fin==0) {
5995       fprintf(stderr,"Could not open file %s\n",file_name);
5996     } else {
5997       if(isfile) {
5998         scheme_load_named_file(&sc,fin,file_name);
5999       } else {
6000         scheme_load_string(&sc,file_name);
6001       }
6002       if(!isfile || fin!=stdin) {
6003         if(sc.retcode!=0) {
6004           fprintf(stderr,"Errors encountered reading %s\n",file_name);
6005         }
6006         if(isfile) {
6007           fclose(fin);
6008         }
6009       }
6010     }
6011     file_name=*argv++;
6012   } while(file_name!=0);
6013   if(argc==1) {
6014     scheme_load_named_file(&sc,stdin,0);
6015   }
6016   retcode=sc.retcode;
6017   scheme_deinit(&sc);
6018
6019   return retcode;
6020 }
6021
6022 #endif
6023
6024 /*
6025 Local variables:
6026 c-file-style: "k&r"
6027 End:
6028 */