LCOV - code coverage report
Current view: top level - tests/gpgscm - scheme.c (source / functions) Hit Total Coverage
Test: coverage.info Lines: 1571 2440 64.4 %
Date: 2016-09-12 12:29:17 Functions: 149 187 79.7 %

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

Generated by: LCOV version 1.11