tests/gpgscm/scheme.c

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