src/scheme.c

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