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