gpgscm: Fix Scheme initialization.
[gnupg.git] / tests / gpgscm / scheme.c
1 /* T I N Y S C H E M E    1 . 4 1
2  *   Dimitrios Souflis (dsouflis@acm.org)
3  *   Based on MiniScheme (original credits follow)
4  * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
5  * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
6  * (MINISCM) This version has been modified by R.C. Secrist.
7  * (MINISCM)
8  * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
9  * (MINISCM)
10  * (MINISCM) This is a revised and modified version by Akira KIDA.
11  * (MINISCM)    current version is 0.85k4 (15 May 1994)
12  *
13  */
14
15 #define _SCHEME_SOURCE
16 #include "scheme-private.h"
17 #ifndef WIN32
18 # include <unistd.h>
19 #endif
20 #ifdef WIN32
21 #define snprintf _snprintf
22 #endif
23 #if USE_DL
24 # include "dynload.h"
25 #endif
26 #if USE_MATH
27 # include <math.h>
28 #endif
29
30 #include <assert.h>
31 #include <limits.h>
32 #include <float.h>
33 #include <ctype.h>
34
35 #if USE_STRCASECMP
36 #include <strings.h>
37 # ifndef __APPLE__
38 #  define stricmp strcasecmp
39 # endif
40 #endif
41
42 /* Used for documentation purposes, to signal functions in 'interface' */
43 #define INTERFACE
44
45 #define TOK_EOF     (-1)
46 #define TOK_LPAREN  0
47 #define TOK_RPAREN  1
48 #define TOK_DOT     2
49 #define TOK_ATOM    3
50 #define TOK_QUOTE   4
51 #define TOK_COMMENT 5
52 #define TOK_DQUOTE  6
53 #define TOK_BQUOTE  7
54 #define TOK_COMMA   8
55 #define TOK_ATMARK  9
56 #define TOK_SHARP   10
57 #define TOK_SHARP_CONST 11
58 #define TOK_VEC     12
59
60 #define BACKQUOTE '`'
61 #define DELIMITERS  "()\";\f\t\v\n\r "
62
63 /*
64  *  Basic memory allocation units
65  */
66
67 #define banner "TinyScheme 1.41"
68
69 #include <string.h>
70 #include <stddef.h>
71 #include <stdlib.h>
72
73 #ifdef __APPLE__
74 static int stricmp(const char *s1, const char *s2)
75 {
76   unsigned char c1, c2;
77   do {
78     c1 = tolower(*s1);
79     c2 = tolower(*s2);
80     if (c1 < c2)
81       return -1;
82     else if (c1 > c2)
83       return 1;
84     s1++, s2++;
85   } while (c1 != 0);
86   return 0;
87 }
88 #endif /* __APPLE__ */
89
90 #if USE_STRLWR
91 static const char *strlwr(char *s) {
92   const char *p=s;
93   while(*s) {
94     *s=tolower(*s);
95     s++;
96   }
97   return p;
98 }
99 #endif
100
101 #ifndef prompt
102 # define prompt "ts> "
103 #endif
104
105 #ifndef InitFile
106 # define InitFile "init.scm"
107 #endif
108
109 #ifndef FIRST_CELLSEGS
110 # define FIRST_CELLSEGS 3
111 #endif
112
113 enum scheme_types {
114   T_STRING=1,
115   T_NUMBER=2,
116   T_SYMBOL=3,
117   T_PROC=4,
118   T_PAIR=5,
119   T_CLOSURE=6,
120   T_CONTINUATION=7,
121   T_FOREIGN=8,
122   T_CHARACTER=9,
123   T_PORT=10,
124   T_VECTOR=11,
125   T_MACRO=12,
126   T_PROMISE=13,
127   T_ENVIRONMENT=14,
128   T_FOREIGN_OBJECT=15,
129   T_LAST_SYSTEM_TYPE=15
130 };
131
132 static const char *
133 type_to_string (enum scheme_types typ)
134 {
135      switch (typ)
136      {
137      case T_STRING: return "string";
138      case T_NUMBER: return "number";
139      case T_SYMBOL: return "symbol";
140      case T_PROC: return "proc";
141      case T_PAIR: return "pair";
142      case T_CLOSURE: return "closure";
143      case T_CONTINUATION: return "configuration";
144      case T_FOREIGN: return "foreign";
145      case T_CHARACTER: return "character";
146      case T_PORT: return "port";
147      case T_VECTOR: return "vector";
148      case T_MACRO: return "macro";
149      case T_PROMISE: return "promise";
150      case T_ENVIRONMENT: return "environment";
151      case T_FOREIGN_OBJECT: return "foreign object";
152      }
153      assert (! "not reached");
154 }
155
156 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
157 #define ADJ 32
158 #define TYPE_BITS 5
159 #define T_MASKTYPE      31    /* 0000000000011111 */
160 #define T_SYNTAX      4096    /* 0001000000000000 */
161 #define T_IMMUTABLE   8192    /* 0010000000000000 */
162 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
163 #define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
164 #define MARK         32768    /* 1000000000000000 */
165 #define UNMARK       32767    /* 0111111111111111 */
166
167
168 static num num_add(num a, num b);
169 static num num_mul(num a, num b);
170 static num num_div(num a, num b);
171 static num num_intdiv(num a, num b);
172 static num num_sub(num a, num b);
173 static num num_rem(num a, num b);
174 static num num_mod(num a, num b);
175 static int num_eq(num a, num b);
176 static int num_gt(num a, num b);
177 static int num_ge(num a, num b);
178 static int num_lt(num a, num b);
179 static int num_le(num a, num b);
180
181 #if USE_MATH
182 static double round_per_R5RS(double x);
183 #endif
184 static int is_zero_double(double x);
185 static INLINE int num_is_integer(pointer p) {
186   return ((p)->_object._number.is_fixnum);
187 }
188
189 static num num_zero;
190 static num num_one;
191
192 /* macros for cell operations */
193 #define typeflag(p)      ((p)->_flag)
194 #define type(p)          (typeflag(p)&T_MASKTYPE)
195
196 INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
197 #define strvalue(p)      ((p)->_object._string._svalue)
198 #define strlength(p)        ((p)->_object._string._length)
199
200 INTERFACE static int is_list(scheme *sc, pointer p);
201 INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
202 INTERFACE static void fill_vector(pointer vec, pointer obj);
203 INTERFACE static pointer vector_elem(pointer vec, int ielem);
204 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
205 INTERFACE INLINE int is_number(pointer p)    { return (type(p)==T_NUMBER); }
206 INTERFACE INLINE int is_integer(pointer p) {
207   if (!is_number(p))
208       return 0;
209   if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
210       return 1;
211   return 0;
212 }
213
214 INTERFACE INLINE int is_real(pointer p) {
215   return is_number(p) && (!(p)->_object._number.is_fixnum);
216 }
217
218 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
219 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
220 INLINE num nvalue(pointer p)       { return ((p)->_object._number); }
221 INTERFACE long ivalue(pointer p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
222 INTERFACE double rvalue(pointer p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
223 #define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
224 #define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
225 #define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
226 #define set_num_real(p)      (p)->_object._number.is_fixnum=0;
227 INTERFACE  long charvalue(pointer p)  { return ivalue_unchecked(p); }
228
229 INTERFACE INLINE int is_port(pointer p)     { return (type(p)==T_PORT); }
230 INTERFACE INLINE int is_inport(pointer p)  { return is_port(p) && p->_object._port->kind & port_input; }
231 INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
232
233 INTERFACE INLINE int is_pair(pointer p)     { return (type(p)==T_PAIR); }
234 #define car(p)           ((p)->_object._cons._car)
235 #define cdr(p)           ((p)->_object._cons._cdr)
236 INTERFACE pointer pair_car(pointer p)   { return car(p); }
237 INTERFACE pointer pair_cdr(pointer p)   { return cdr(p); }
238 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
239 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
240
241 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
242 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
243 #if USE_PLIST
244 SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (typeflag(p)&T_SYMBOL); }
245 #define symprop(p)       cdr(p)
246 #endif
247
248 INTERFACE INLINE int is_syntax(pointer p)   { return (typeflag(p)&T_SYNTAX); }
249 INTERFACE INLINE int is_proc(pointer p)     { return (type(p)==T_PROC); }
250 INTERFACE INLINE int is_foreign(pointer p)  { return (type(p)==T_FOREIGN); }
251 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
252 #define procnum(p)       ivalue(p)
253 static const char *procname(pointer x);
254
255 INTERFACE INLINE int is_closure(pointer p)  { return (type(p)==T_CLOSURE); }
256 INTERFACE INLINE int is_macro(pointer p)    { return (type(p)==T_MACRO); }
257 INTERFACE INLINE pointer closure_code(pointer p)   { return car(p); }
258 INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
259
260 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
261 #define cont_dump(p)     cdr(p)
262
263 INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
264 INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
265   return p->_object._foreign_object._vtable;
266 }
267 INTERFACE void *get_foreign_object_data(pointer p) {
268   return p->_object._foreign_object._data;
269 }
270
271 /* To do: promise should be forced ONCE only */
272 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
273
274 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
275 #define setenvironment(p)    typeflag(p) = T_ENVIRONMENT
276
277 #define is_atom(p)       (typeflag(p)&T_ATOM)
278 #define setatom(p)       typeflag(p) |= T_ATOM
279 #define clratom(p)       typeflag(p) &= CLRATOM
280
281 #define is_mark(p)       (typeflag(p)&MARK)
282 #define setmark(p)       typeflag(p) |= MARK
283 #define clrmark(p)       typeflag(p) &= UNMARK
284
285 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
286 /*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
287 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
288
289 #define caar(p)          car(car(p))
290 #define cadr(p)          car(cdr(p))
291 #define cdar(p)          cdr(car(p))
292 #define cddr(p)          cdr(cdr(p))
293 #define cadar(p)         car(cdr(car(p)))
294 #define caddr(p)         car(cdr(cdr(p)))
295 #define cdaar(p)         cdr(car(car(p)))
296 #define cadaar(p)        car(cdr(car(car(p))))
297 #define cadddr(p)        car(cdr(cdr(cdr(p))))
298 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
299
300 #if USE_CHAR_CLASSIFIERS
301 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
302 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
303 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
304 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
305 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
306 #endif
307
308 #if USE_ASCII_NAMES
309 static const char *charnames[32]={
310  "nul",
311  "soh",
312  "stx",
313  "etx",
314  "eot",
315  "enq",
316  "ack",
317  "bel",
318  "bs",
319  "ht",
320  "lf",
321  "vt",
322  "ff",
323  "cr",
324  "so",
325  "si",
326  "dle",
327  "dc1",
328  "dc2",
329  "dc3",
330  "dc4",
331  "nak",
332  "syn",
333  "etb",
334  "can",
335  "em",
336  "sub",
337  "esc",
338  "fs",
339  "gs",
340  "rs",
341  "us"
342 };
343
344 static int is_ascii_name(const char *name, int *pc) {
345   int i;
346   for(i=0; i<32; i++) {
347      if(stricmp(name,charnames[i])==0) {
348           *pc=i;
349           return 1;
350      }
351   }
352   if(stricmp(name,"del")==0) {
353      *pc=127;
354      return 1;
355   }
356   return 0;
357 }
358
359 #endif
360
361 static int file_push(scheme *sc, const char *fname);
362 static void file_pop(scheme *sc);
363 static int file_interactive(scheme *sc);
364 static INLINE int is_one_of(char *s, int c);
365 static int alloc_cellseg(scheme *sc, int n);
366 static long binary_decode(const char *s);
367 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
368 static pointer _get_cell(scheme *sc, pointer a, pointer b);
369 static pointer reserve_cells(scheme *sc, int n);
370 static pointer get_consecutive_cells(scheme *sc, int n);
371 static pointer find_consecutive_cells(scheme *sc, int n);
372 static void finalize_cell(scheme *sc, pointer a);
373 static int count_consecutive_cells(pointer x, int needed);
374 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
375 static pointer mk_number(scheme *sc, num n);
376 static char *store_string(scheme *sc, int len, const char *str, char fill);
377 static pointer mk_vector(scheme *sc, int len);
378 static pointer mk_atom(scheme *sc, char *q);
379 static pointer mk_sharp_const(scheme *sc, char *name);
380 static pointer mk_port(scheme *sc, port *p);
381 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
382 static pointer port_from_file(scheme *sc, FILE *, int prop);
383 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
384 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
385 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
386 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
387 static void port_close(scheme *sc, pointer p, int flag);
388 static void mark(pointer a);
389 static void gc(scheme *sc, pointer a, pointer b);
390 static int basic_inchar(port *pt);
391 static int inchar(scheme *sc);
392 static void backchar(scheme *sc, int c);
393 static char   *readstr_upto(scheme *sc, char *delim);
394 static pointer readstrexp(scheme *sc);
395 static INLINE int skipspace(scheme *sc);
396 static int token(scheme *sc);
397 static void printslashstring(scheme *sc, char *s, int len);
398 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
399 static void printatom(scheme *sc, pointer l, int f);
400 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
401 static pointer mk_closure(scheme *sc, pointer c, pointer e);
402 static pointer mk_continuation(scheme *sc, pointer d);
403 static pointer reverse(scheme *sc, pointer a);
404 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
405 static pointer revappend(scheme *sc, pointer a, pointer b);
406 static void dump_stack_mark(scheme *);
407 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
408 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
409 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
410 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
411 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
412 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
413 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
414 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
415 static void assign_syntax(scheme *sc, char *name);
416 static int syntaxnum(pointer p);
417 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
418
419 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
420 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
421
422 static num num_add(num a, num b) {
423  num ret;
424  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
425  if(ret.is_fixnum) {
426      ret.value.ivalue= a.value.ivalue+b.value.ivalue;
427  } else {
428      ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
429  }
430  return ret;
431 }
432
433 static num num_mul(num a, num b) {
434  num ret;
435  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
436  if(ret.is_fixnum) {
437      ret.value.ivalue= a.value.ivalue*b.value.ivalue;
438  } else {
439      ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
440  }
441  return ret;
442 }
443
444 static num num_div(num a, num b) {
445  num ret;
446  ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
447  if(ret.is_fixnum) {
448      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
449  } else {
450      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
451  }
452  return ret;
453 }
454
455 static num num_intdiv(num a, num b) {
456  num ret;
457  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
458  if(ret.is_fixnum) {
459      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
460  } else {
461      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
462  }
463  return ret;
464 }
465
466 static num num_sub(num a, num b) {
467  num ret;
468  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
469  if(ret.is_fixnum) {
470      ret.value.ivalue= a.value.ivalue-b.value.ivalue;
471  } else {
472      ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
473  }
474  return ret;
475 }
476
477 static num num_rem(num a, num b) {
478  num ret;
479  long e1, e2, res;
480  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
481  e1=num_ivalue(a);
482  e2=num_ivalue(b);
483  res=e1%e2;
484  /* remainder should have same sign as second operand */
485  if (res > 0) {
486      if (e1 < 0) {
487         res -= labs(e2);
488      }
489  } else if (res < 0) {
490      if (e1 > 0) {
491          res += labs(e2);
492      }
493  }
494  ret.value.ivalue=res;
495  return ret;
496 }
497
498 static num num_mod(num a, num b) {
499  num ret;
500  long e1, e2, res;
501  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
502  e1=num_ivalue(a);
503  e2=num_ivalue(b);
504  res=e1%e2;
505  /* modulo should have same sign as second operand */
506  if (res * e2 < 0) {
507     res += e2;
508  }
509  ret.value.ivalue=res;
510  return ret;
511 }
512
513 static int num_eq(num a, num b) {
514  int ret;
515  int is_fixnum=a.is_fixnum && b.is_fixnum;
516  if(is_fixnum) {
517      ret= a.value.ivalue==b.value.ivalue;
518  } else {
519      ret=num_rvalue(a)==num_rvalue(b);
520  }
521  return ret;
522 }
523
524
525 static int num_gt(num a, num b) {
526  int ret;
527  int is_fixnum=a.is_fixnum && b.is_fixnum;
528  if(is_fixnum) {
529      ret= a.value.ivalue>b.value.ivalue;
530  } else {
531      ret=num_rvalue(a)>num_rvalue(b);
532  }
533  return ret;
534 }
535
536 static int num_ge(num a, num b) {
537  return !num_lt(a,b);
538 }
539
540 static int num_lt(num a, num b) {
541  int ret;
542  int is_fixnum=a.is_fixnum && b.is_fixnum;
543  if(is_fixnum) {
544      ret= a.value.ivalue<b.value.ivalue;
545  } else {
546      ret=num_rvalue(a)<num_rvalue(b);
547  }
548  return ret;
549 }
550
551 static int num_le(num a, num b) {
552  return !num_gt(a,b);
553 }
554
555 #if USE_MATH
556 /* Round to nearest. Round to even if midway */
557 static double round_per_R5RS(double x) {
558  double fl=floor(x);
559  double ce=ceil(x);
560  double dfl=x-fl;
561  double dce=ce-x;
562  if(dfl>dce) {
563      return ce;
564  } else if(dfl<dce) {
565      return fl;
566  } else {
567      if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
568           return fl;
569      } else {
570           return ce;
571      }
572  }
573 }
574 #endif
575
576 static int is_zero_double(double x) {
577  return x<DBL_MIN && x>-DBL_MIN;
578 }
579
580 static long binary_decode(const char *s) {
581  long x=0;
582
583  while(*s!=0 && (*s=='1' || *s=='0')) {
584      x<<=1;
585      x+=*s-'0';
586      s++;
587  }
588
589  return x;
590 }
591
592 /* allocate new cell segment */
593 static int alloc_cellseg(scheme *sc, int n) {
594      pointer newp;
595      pointer last;
596      pointer p;
597      char *cp;
598      long i;
599      int k;
600      int adj=ADJ;
601
602      if(adj<sizeof(struct cell)) {
603        adj=sizeof(struct cell);
604      }
605
606      for (k = 0; k < n; k++) {
607          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
608               return k;
609          cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
610          if (cp == 0)
611               return k;
612          i = ++sc->last_cell_seg ;
613          sc->alloc_seg[i] = cp;
614          /* adjust in TYPE_BITS-bit boundary */
615          if(((unsigned long)cp)%adj!=0) {
616            cp=(char*)(adj*((unsigned long)cp/adj+1));
617          }
618          /* insert new segment in address order */
619          newp=(pointer)cp;
620          sc->cell_seg[i] = newp;
621          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
622              p = sc->cell_seg[i];
623              sc->cell_seg[i] = sc->cell_seg[i - 1];
624              sc->cell_seg[--i] = p;
625          }
626          sc->fcells += CELL_SEGSIZE;
627          last = newp + CELL_SEGSIZE - 1;
628          for (p = newp; p <= last; p++) {
629               typeflag(p) = 0;
630               cdr(p) = p + 1;
631               car(p) = sc->NIL;
632          }
633          /* insert new cells in address order on free list */
634          if (sc->free_cell == sc->NIL || p < sc->free_cell) {
635               cdr(last) = sc->free_cell;
636               sc->free_cell = newp;
637          } else {
638                p = sc->free_cell;
639                while (cdr(p) != sc->NIL && newp > cdr(p))
640                     p = cdr(p);
641                cdr(last) = cdr(p);
642                cdr(p) = newp;
643          }
644      }
645      return n;
646 }
647
648 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
649   if (sc->free_cell != sc->NIL) {
650     pointer x = sc->free_cell;
651     sc->free_cell = cdr(x);
652     --sc->fcells;
653     return (x);
654   }
655   return _get_cell (sc, a, b);
656 }
657
658
659 /* get new cell.  parameter a, b is marked by gc. */
660 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
661   pointer x;
662
663   if(sc->no_memory) {
664     return sc->sink;
665   }
666
667   if (sc->free_cell == sc->NIL) {
668     const int min_to_be_recovered = sc->last_cell_seg*8;
669     gc(sc,a, b);
670     if (sc->fcells < min_to_be_recovered
671         || sc->free_cell == sc->NIL) {
672       /* if only a few recovered, get more to avoid fruitless gc's */
673       if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
674         sc->no_memory=1;
675         return sc->sink;
676       }
677     }
678   }
679   x = sc->free_cell;
680   sc->free_cell = cdr(x);
681   --sc->fcells;
682   return (x);
683 }
684
685 /* make sure that there is a given number of cells free */
686 static pointer reserve_cells(scheme *sc, int n) {
687     if(sc->no_memory) {
688         return sc->NIL;
689     }
690
691     /* Are there enough cells available? */
692     if (sc->fcells < n) {
693         /* If not, try gc'ing some */
694         gc(sc, sc->NIL, sc->NIL);
695         if (sc->fcells < n) {
696             /* If there still aren't, try getting more heap */
697             if (!alloc_cellseg(sc,1)) {
698                 sc->no_memory=1;
699                 return sc->NIL;
700             }
701         }
702         if (sc->fcells < n) {
703             /* If all fail, report failure */
704             sc->no_memory=1;
705             return sc->NIL;
706         }
707     }
708     return (sc->T);
709 }
710
711 static pointer get_consecutive_cells(scheme *sc, int n) {
712   pointer x;
713
714   if(sc->no_memory) { return sc->sink; }
715
716   /* Are there any cells available? */
717   x=find_consecutive_cells(sc,n);
718   if (x != sc->NIL) { return x; }
719
720   /* If not, try gc'ing some */
721   gc(sc, sc->NIL, sc->NIL);
722   x=find_consecutive_cells(sc,n);
723   if (x != sc->NIL) { return x; }
724
725   /* If there still aren't, try getting more heap */
726   if (!alloc_cellseg(sc,1))
727     {
728       sc->no_memory=1;
729       return sc->sink;
730     }
731
732   x=find_consecutive_cells(sc,n);
733   if (x != sc->NIL) { return x; }
734
735   /* If all fail, report failure */
736   sc->no_memory=1;
737   return sc->sink;
738 }
739
740 static int count_consecutive_cells(pointer x, int needed) {
741  int n=1;
742  while(cdr(x)==x+1) {
743      x=cdr(x);
744      n++;
745      if(n>needed) return n;
746  }
747  return n;
748 }
749
750 static pointer find_consecutive_cells(scheme *sc, int n) {
751   pointer *pp;
752   int cnt;
753
754   pp=&sc->free_cell;
755   while(*pp!=sc->NIL) {
756     cnt=count_consecutive_cells(*pp,n);
757     if(cnt>=n) {
758       pointer x=*pp;
759       *pp=cdr(*pp+n-1);
760       sc->fcells -= n;
761       return x;
762     }
763     pp=&cdr(*pp+cnt-1);
764   }
765   return sc->NIL;
766 }
767
768 /* To retain recent allocs before interpreter knows about them -
769    Tehom */
770
771 static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
772 {
773   pointer holder = get_cell_x(sc, recent, extra);
774   typeflag(holder) = T_PAIR | T_IMMUTABLE;
775   car(holder) = recent;
776   cdr(holder) = car(sc->sink);
777   car(sc->sink) = holder;
778 }
779
780
781 static pointer get_cell(scheme *sc, pointer a, pointer b)
782 {
783   pointer cell   = get_cell_x(sc, a, b);
784   /* For right now, include "a" and "b" in "cell" so that gc doesn't
785      think they are garbage. */
786   /* Tentatively record it as a pair so gc understands it. */
787   typeflag(cell) = T_PAIR;
788   car(cell) = a;
789   cdr(cell) = b;
790   push_recent_alloc(sc, cell, sc->NIL);
791   return cell;
792 }
793
794 static pointer get_vector_object(scheme *sc, int len, pointer init)
795 {
796   pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
797   if(sc->no_memory) { return sc->sink; }
798   /* Record it as a vector so that gc understands it. */
799   typeflag(cells) = (T_VECTOR | T_ATOM);
800   ivalue_unchecked(cells)=len;
801   set_num_integer(cells);
802   fill_vector(cells,init);
803   push_recent_alloc(sc, cells, sc->NIL);
804   return cells;
805 }
806
807 static INLINE void ok_to_freely_gc(scheme *sc)
808 {
809   car(sc->sink) = sc->NIL;
810 }
811
812
813 #if defined TSGRIND
814 static void check_cell_alloced(pointer p, int expect_alloced)
815 {
816   /* Can't use putstr(sc,str) because callers have no access to
817      sc.  */
818   if(typeflag(p) & !expect_alloced)
819     {
820       fprintf(stderr,"Cell is already allocated!\n");
821     }
822   if(!(typeflag(p)) & expect_alloced)
823     {
824       fprintf(stderr,"Cell is not allocated!\n");
825     }
826
827 }
828 static void check_range_alloced(pointer p, int n, int expect_alloced)
829 {
830   int i;
831   for(i = 0;i<n;i++)
832     { (void)check_cell_alloced(p+i,expect_alloced); }
833 }
834
835 #endif
836
837 /* Medium level cell allocation */
838
839 /* get new cons cell */
840 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
841   pointer x = get_cell(sc,a, b);
842
843   typeflag(x) = T_PAIR;
844   if(immutable) {
845     setimmutable(x);
846   }
847   car(x) = a;
848   cdr(x) = b;
849   return (x);
850 }
851
852 /* ========== oblist implementation  ========== */
853
854 #ifndef USE_OBJECT_LIST
855
856 static int hash_fn(const char *key, int table_size);
857
858 static pointer oblist_initial_value(scheme *sc)
859 {
860   return mk_vector(sc, 461); /* probably should be bigger */
861 }
862
863 /* returns the new symbol */
864 static pointer oblist_add_by_name(scheme *sc, const char *name)
865 {
866   pointer x;
867   int location;
868
869   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
870   typeflag(x) = T_SYMBOL;
871   setimmutable(car(x));
872
873   location = hash_fn(name, ivalue_unchecked(sc->oblist));
874   set_vector_elem(sc->oblist, location,
875                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
876   return x;
877 }
878
879 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
880 {
881   int location;
882   pointer x;
883   char *s;
884
885   location = hash_fn(name, ivalue_unchecked(sc->oblist));
886   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
887     s = symname(car(x));
888     /* case-insensitive, per R5RS section 2. */
889     if(stricmp(name, s) == 0) {
890       return car(x);
891     }
892   }
893   return sc->NIL;
894 }
895
896 static pointer oblist_all_symbols(scheme *sc)
897 {
898   int i;
899   pointer x;
900   pointer ob_list = sc->NIL;
901
902   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
903     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
904       ob_list = cons(sc, x, ob_list);
905     }
906   }
907   return ob_list;
908 }
909
910 #else
911
912 static pointer oblist_initial_value(scheme *sc)
913 {
914   return sc->NIL;
915 }
916
917 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
918 {
919      pointer x;
920      char    *s;
921
922      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
923         s = symname(car(x));
924         /* case-insensitive, per R5RS section 2. */
925         if(stricmp(name, s) == 0) {
926           return car(x);
927         }
928      }
929      return sc->NIL;
930 }
931
932 /* returns the new symbol */
933 static pointer oblist_add_by_name(scheme *sc, const char *name)
934 {
935   pointer x;
936
937   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
938   typeflag(x) = T_SYMBOL;
939   setimmutable(car(x));
940   sc->oblist = immutable_cons(sc, x, sc->oblist);
941   return x;
942 }
943 static pointer oblist_all_symbols(scheme *sc)
944 {
945   return sc->oblist;
946 }
947
948 #endif
949
950 static pointer mk_port(scheme *sc, port *p) {
951   pointer x = get_cell(sc, sc->NIL, sc->NIL);
952
953   typeflag(x) = T_PORT|T_ATOM;
954   x->_object._port=p;
955   return (x);
956 }
957
958 pointer mk_foreign_func(scheme *sc, foreign_func f) {
959   pointer x = get_cell(sc, sc->NIL, sc->NIL);
960
961   typeflag(x) = (T_FOREIGN | T_ATOM);
962   x->_object._ff=f;
963   return (x);
964 }
965
966 pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
967   pointer x = get_cell(sc, sc->NIL, sc->NIL);
968
969   typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM);
970   x->_object._foreign_object._vtable=vtable;
971   x->_object._foreign_object._data = data;
972   return (x);
973 }
974
975 INTERFACE pointer mk_character(scheme *sc, int c) {
976   pointer x = get_cell(sc,sc->NIL, sc->NIL);
977
978   typeflag(x) = (T_CHARACTER | T_ATOM);
979   ivalue_unchecked(x)= c;
980   set_num_integer(x);
981   return (x);
982 }
983
984 /* get number atom (integer) */
985 INTERFACE pointer mk_integer(scheme *sc, long n) {
986   pointer x = get_cell(sc,sc->NIL, sc->NIL);
987
988   typeflag(x) = (T_NUMBER | T_ATOM);
989   ivalue_unchecked(x)= n;
990   set_num_integer(x);
991   return (x);
992 }
993
994 INTERFACE pointer mk_real(scheme *sc, double n) {
995   pointer x = get_cell(sc,sc->NIL, sc->NIL);
996
997   typeflag(x) = (T_NUMBER | T_ATOM);
998   rvalue_unchecked(x)= n;
999   set_num_real(x);
1000   return (x);
1001 }
1002
1003 static pointer mk_number(scheme *sc, num n) {
1004  if(n.is_fixnum) {
1005      return mk_integer(sc,n.value.ivalue);
1006  } else {
1007      return mk_real(sc,n.value.rvalue);
1008  }
1009 }
1010
1011 /* allocate name to string area */
1012 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
1013      char *q;
1014
1015      q=(char*)sc->malloc(len_str+1);
1016      if(q==0) {
1017           sc->no_memory=1;
1018           return sc->strbuff;
1019      }
1020      if(str!=0) {
1021           snprintf(q, len_str+1, "%s", str);
1022      } else {
1023           memset(q, fill, len_str);
1024           q[len_str]=0;
1025      }
1026      return (q);
1027 }
1028
1029 /* get new string */
1030 INTERFACE pointer mk_string(scheme *sc, const char *str) {
1031      return mk_counted_string(sc,str,strlen(str));
1032 }
1033
1034 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
1035      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1036      typeflag(x) = (T_STRING | T_ATOM);
1037      strvalue(x) = store_string(sc,len,str,0);
1038      strlength(x) = len;
1039      return (x);
1040 }
1041
1042 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
1043      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1044      typeflag(x) = (T_STRING | T_ATOM);
1045      strvalue(x) = store_string(sc,len,0,fill);
1046      strlength(x) = len;
1047      return (x);
1048 }
1049
1050 INTERFACE static pointer mk_vector(scheme *sc, int len)
1051 { return get_vector_object(sc,len,sc->NIL); }
1052
1053 INTERFACE static void fill_vector(pointer vec, pointer obj) {
1054      int i;
1055      int n = ivalue(vec)/2+ivalue(vec)%2;
1056      for(i=0; i < n; i++) {
1057           typeflag(vec+1+i) = T_PAIR;
1058           setimmutable(vec+1+i);
1059           car(vec+1+i)=obj;
1060           cdr(vec+1+i)=obj;
1061      }
1062 }
1063
1064 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1065      int n=ielem/2;
1066      if(ielem%2==0) {
1067           return car(vec+1+n);
1068      } else {
1069           return cdr(vec+1+n);
1070      }
1071 }
1072
1073 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1074      int n=ielem/2;
1075      if(ielem%2==0) {
1076           return car(vec+1+n)=a;
1077      } else {
1078           return cdr(vec+1+n)=a;
1079      }
1080 }
1081
1082 /* get new symbol */
1083 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1084      pointer x;
1085
1086      /* first check oblist */
1087      x = oblist_find_by_name(sc, name);
1088      if (x != sc->NIL) {
1089           return (x);
1090      } else {
1091           x = oblist_add_by_name(sc, name);
1092           return (x);
1093      }
1094 }
1095
1096 INTERFACE pointer gensym(scheme *sc) {
1097      pointer x;
1098      char name[40];
1099
1100      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1101           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1102
1103           /* first check oblist */
1104           x = oblist_find_by_name(sc, name);
1105
1106           if (x != sc->NIL) {
1107                continue;
1108           } else {
1109                x = oblist_add_by_name(sc, name);
1110                return (x);
1111           }
1112      }
1113
1114      return sc->NIL;
1115 }
1116
1117 /* double the size of the string buffer */
1118 static int expand_strbuff(scheme *sc) {
1119   size_t new_size = sc->strbuff_size * 2;
1120   char *new_buffer = sc->malloc(new_size);
1121   if (new_buffer == 0) {
1122     sc->no_memory = 1;
1123     return 1;
1124   }
1125   memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
1126   sc->free(sc->strbuff);
1127   sc->strbuff = new_buffer;
1128   sc->strbuff_size = new_size;
1129   return 0;
1130 }
1131
1132 /* make symbol or number atom from string */
1133 static pointer mk_atom(scheme *sc, char *q) {
1134      char    c, *p;
1135      int has_dec_point=0;
1136      int has_fp_exp = 0;
1137
1138 #if USE_COLON_HOOK
1139      if((p=strstr(q,"::"))!=0) {
1140           *p=0;
1141           return cons(sc, sc->COLON_HOOK,
1142                           cons(sc,
1143                               cons(sc,
1144                                    sc->QUOTE,
1145                                    cons(sc, mk_atom(sc,p+2), sc->NIL)),
1146                               cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
1147      }
1148 #endif
1149
1150      p = q;
1151      c = *p++;
1152      if ((c == '+') || (c == '-')) {
1153        c = *p++;
1154        if (c == '.') {
1155          has_dec_point=1;
1156          c = *p++;
1157        }
1158        if (!isdigit(c)) {
1159          return (mk_symbol(sc, strlwr(q)));
1160        }
1161      } else if (c == '.') {
1162        has_dec_point=1;
1163        c = *p++;
1164        if (!isdigit(c)) {
1165          return (mk_symbol(sc, strlwr(q)));
1166        }
1167      } else if (!isdigit(c)) {
1168        return (mk_symbol(sc, strlwr(q)));
1169      }
1170
1171      for ( ; (c = *p) != 0; ++p) {
1172           if (!isdigit(c)) {
1173                if(c=='.') {
1174                     if(!has_dec_point) {
1175                          has_dec_point=1;
1176                          continue;
1177                     }
1178                }
1179                else if ((c == 'e') || (c == 'E')) {
1180                        if(!has_fp_exp) {
1181                           has_dec_point = 1; /* decimal point illegal
1182                                                 from now on */
1183                           p++;
1184                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1185                              continue;
1186                           }
1187                        }
1188                }
1189                return (mk_symbol(sc, strlwr(q)));
1190           }
1191      }
1192      if(has_dec_point) {
1193           return mk_real(sc,atof(q));
1194      }
1195      return (mk_integer(sc, atol(q)));
1196 }
1197
1198 /* make constant */
1199 static pointer mk_sharp_const(scheme *sc, char *name) {
1200      long    x;
1201      char    tmp[STRBUFFSIZE];
1202
1203      if (!strcmp(name, "t"))
1204           return (sc->T);
1205      else if (!strcmp(name, "f"))
1206           return (sc->F);
1207      else if (*name == 'o') {/* #o (octal) */
1208           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1209           sscanf(tmp, "%lo", (long unsigned *)&x);
1210           return (mk_integer(sc, x));
1211      } else if (*name == 'd') {    /* #d (decimal) */
1212           sscanf(name+1, "%ld", (long int *)&x);
1213           return (mk_integer(sc, x));
1214      } else if (*name == 'x') {    /* #x (hex) */
1215           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
1216           sscanf(tmp, "%lx", (long unsigned *)&x);
1217           return (mk_integer(sc, x));
1218      } else if (*name == 'b') {    /* #b (binary) */
1219           x = binary_decode(name+1);
1220           return (mk_integer(sc, x));
1221      } else if (*name == '\\') { /* #\w (character) */
1222           int c=0;
1223           if(stricmp(name+1,"space")==0) {
1224                c=' ';
1225           } else if(stricmp(name+1,"newline")==0) {
1226                c='\n';
1227           } else if(stricmp(name+1,"return")==0) {
1228                c='\r';
1229           } else if(stricmp(name+1,"tab")==0) {
1230                c='\t';
1231      } else if(name[1]=='x' && name[2]!=0) {
1232           int c1=0;
1233           if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
1234                c=c1;
1235           } else {
1236                return sc->NIL;
1237      }
1238 #if USE_ASCII_NAMES
1239           } else if(is_ascii_name(name+1,&c)) {
1240                /* nothing */
1241 #endif
1242           } else if(name[2]==0) {
1243                c=name[1];
1244           } else {
1245                return sc->NIL;
1246           }
1247           return mk_character(sc,c);
1248      } else
1249           return (sc->NIL);
1250 }
1251
1252 /* ========== garbage collector ========== */
1253
1254 /*--
1255  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1256  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1257  *  for marking.
1258  */
1259 static void mark(pointer a) {
1260      pointer t, q, p;
1261
1262      t = (pointer) 0;
1263      p = a;
1264 E2:  setmark(p);
1265      if(is_vector(p)) {
1266           int i;
1267           int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1268           for(i=0; i < n; i++) {
1269                /* Vector cells will be treated like ordinary cells */
1270                mark(p+1+i);
1271           }
1272      }
1273      if (is_atom(p))
1274           goto E6;
1275      /* E4: down car */
1276      q = car(p);
1277      if (q && !is_mark(q)) {
1278           setatom(p);  /* a note that we have moved car */
1279           car(p) = t;
1280           t = p;
1281           p = q;
1282           goto E2;
1283      }
1284 E5:  q = cdr(p); /* down cdr */
1285      if (q && !is_mark(q)) {
1286           cdr(p) = t;
1287           t = p;
1288           p = q;
1289           goto E2;
1290      }
1291 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1292      if (!t)
1293           return;
1294      q = t;
1295      if (is_atom(q)) {
1296           clratom(q);
1297           t = car(q);
1298           car(q) = p;
1299           p = q;
1300           goto E5;
1301      } else {
1302           t = cdr(q);
1303           cdr(q) = p;
1304           p = q;
1305           goto E6;
1306      }
1307 }
1308
1309 /* garbage collection. parameter a, b is marked. */
1310 static void gc(scheme *sc, pointer a, pointer b) {
1311   pointer p;
1312   int i;
1313
1314   if(sc->gc_verbose) {
1315     putstr(sc, "gc...");
1316   }
1317
1318   /* mark system globals */
1319   mark(sc->oblist);
1320   mark(sc->global_env);
1321
1322   /* mark current registers */
1323   mark(sc->args);
1324   mark(sc->envir);
1325   mark(sc->code);
1326   dump_stack_mark(sc);
1327   mark(sc->value);
1328   mark(sc->inport);
1329   mark(sc->save_inport);
1330   mark(sc->outport);
1331   mark(sc->loadport);
1332
1333   /* Mark recent objects the interpreter doesn't know about yet. */
1334   mark(car(sc->sink));
1335   /* Mark any older stuff above nested C calls */
1336   mark(sc->c_nest);
1337
1338   /* mark variables a, b */
1339   mark(a);
1340   mark(b);
1341
1342   /* garbage collect */
1343   clrmark(sc->NIL);
1344   sc->fcells = 0;
1345   sc->free_cell = sc->NIL;
1346   /* free-list is kept sorted by address so as to maintain consecutive
1347      ranges, if possible, for use with vectors. Here we scan the cells
1348      (which are also kept sorted by address) downwards to build the
1349      free-list in sorted order.
1350   */
1351   for (i = sc->last_cell_seg; i >= 0; i--) {
1352     p = sc->cell_seg[i] + CELL_SEGSIZE;
1353     while (--p >= sc->cell_seg[i]) {
1354       if (is_mark(p)) {
1355     clrmark(p);
1356       } else {
1357     /* reclaim cell */
1358         if (typeflag(p) != 0) {
1359           finalize_cell(sc, p);
1360           typeflag(p) = 0;
1361           car(p) = sc->NIL;
1362         }
1363         ++sc->fcells;
1364         cdr(p) = sc->free_cell;
1365         sc->free_cell = p;
1366       }
1367     }
1368   }
1369
1370   if (sc->gc_verbose) {
1371     char msg[80];
1372     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1373     putstr(sc,msg);
1374   }
1375 }
1376
1377 static void finalize_cell(scheme *sc, pointer a) {
1378   if(is_string(a)) {
1379     sc->free(strvalue(a));
1380   } else if(is_port(a)) {
1381     if(a->_object._port->kind&port_file
1382        && a->_object._port->rep.stdio.closeit) {
1383       port_close(sc,a,port_input|port_output);
1384     }
1385     sc->free(a->_object._port);
1386   } else if(is_foreign_object(a)) {
1387     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1388   }
1389 }
1390
1391 /* ========== Routines for Reading ========== */
1392
1393 static int file_push(scheme *sc, const char *fname) {
1394   FILE *fin = NULL;
1395
1396   if (sc->file_i == MAXFIL-1)
1397      return 0;
1398   fin=fopen(fname,"r");
1399   if(fin!=0) {
1400     sc->file_i++;
1401     sc->load_stack[sc->file_i].kind=port_file|port_input;
1402     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1403     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1404     sc->nesting_stack[sc->file_i]=0;
1405     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1406
1407 #if SHOW_ERROR_LINE
1408     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1409     if(fname)
1410       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1411 #endif
1412   }
1413   return fin!=0;
1414 }
1415
1416 static void file_pop(scheme *sc) {
1417  if(sc->file_i != 0) {
1418    sc->nesting=sc->nesting_stack[sc->file_i];
1419    port_close(sc,sc->loadport,port_input);
1420    sc->file_i--;
1421    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1422  }
1423 }
1424
1425 static int file_interactive(scheme *sc) {
1426  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1427      && sc->inport->_object._port->kind&port_file;
1428 }
1429
1430 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1431   FILE *f;
1432   char *rw;
1433   port *pt;
1434   if(prop==(port_input|port_output)) {
1435     rw="a+";
1436   } else if(prop==port_output) {
1437     rw="w";
1438   } else {
1439     rw="r";
1440   }
1441   f=fopen(fn,rw);
1442   if(f==0) {
1443     return 0;
1444   }
1445   pt=port_rep_from_file(sc,f,prop);
1446   pt->rep.stdio.closeit=1;
1447
1448 #if SHOW_ERROR_LINE
1449   if(fn)
1450     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1451
1452   pt->rep.stdio.curr_line = 0;
1453 #endif
1454   return pt;
1455 }
1456
1457 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1458   port *pt;
1459   pt=port_rep_from_filename(sc,fn,prop);
1460   if(pt==0) {
1461     return sc->NIL;
1462   }
1463   return mk_port(sc,pt);
1464 }
1465
1466 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1467 {
1468     port *pt;
1469
1470     pt = (port *)sc->malloc(sizeof *pt);
1471     if (pt == NULL) {
1472         return NULL;
1473     }
1474     pt->kind = port_file | prop;
1475     pt->rep.stdio.file = f;
1476     pt->rep.stdio.closeit = 0;
1477     return pt;
1478 }
1479
1480 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1481   port *pt;
1482   pt=port_rep_from_file(sc,f,prop);
1483   if(pt==0) {
1484     return sc->NIL;
1485   }
1486   return mk_port(sc,pt);
1487 }
1488
1489 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1490   port *pt;
1491   pt=(port*)sc->malloc(sizeof(port));
1492   if(pt==0) {
1493     return 0;
1494   }
1495   pt->kind=port_string|prop;
1496   pt->rep.string.start=start;
1497   pt->rep.string.curr=start;
1498   pt->rep.string.past_the_end=past_the_end;
1499   return pt;
1500 }
1501
1502 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1503   port *pt;
1504   pt=port_rep_from_string(sc,start,past_the_end,prop);
1505   if(pt==0) {
1506     return sc->NIL;
1507   }
1508   return mk_port(sc,pt);
1509 }
1510
1511 #define BLOCK_SIZE 256
1512
1513 static port *port_rep_from_scratch(scheme *sc) {
1514   port *pt;
1515   char *start;
1516   pt=(port*)sc->malloc(sizeof(port));
1517   if(pt==0) {
1518     return 0;
1519   }
1520   start=sc->malloc(BLOCK_SIZE);
1521   if(start==0) {
1522     return 0;
1523   }
1524   memset(start,' ',BLOCK_SIZE-1);
1525   start[BLOCK_SIZE-1]='\0';
1526   pt->kind=port_string|port_output|port_srfi6;
1527   pt->rep.string.start=start;
1528   pt->rep.string.curr=start;
1529   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1530   return pt;
1531 }
1532
1533 static pointer port_from_scratch(scheme *sc) {
1534   port *pt;
1535   pt=port_rep_from_scratch(sc);
1536   if(pt==0) {
1537     return sc->NIL;
1538   }
1539   return mk_port(sc,pt);
1540 }
1541
1542 static void port_close(scheme *sc, pointer p, int flag) {
1543   port *pt=p->_object._port;
1544   pt->kind&=~flag;
1545   if((pt->kind & (port_input|port_output))==0) {
1546     if(pt->kind&port_file) {
1547
1548 #if SHOW_ERROR_LINE
1549       /* Cleanup is here so (close-*-port) functions could work too */
1550       pt->rep.stdio.curr_line = 0;
1551
1552       if(pt->rep.stdio.filename)
1553         sc->free(pt->rep.stdio.filename);
1554 #endif
1555
1556       fclose(pt->rep.stdio.file);
1557     }
1558     pt->kind=port_free;
1559   }
1560 }
1561
1562 /* get new character from input file */
1563 static int inchar(scheme *sc) {
1564   int c;
1565   port *pt;
1566
1567   pt = sc->inport->_object._port;
1568   if(pt->kind & port_saw_EOF)
1569     { return EOF; }
1570   c = basic_inchar(pt);
1571   if(c == EOF && sc->inport == sc->loadport) {
1572     /* Instead, set port_saw_EOF */
1573     pt->kind |= port_saw_EOF;
1574
1575     /* file_pop(sc); */
1576     return EOF;
1577     /* NOTREACHED */
1578   }
1579   return c;
1580 }
1581
1582 static int basic_inchar(port *pt) {
1583   if(pt->kind & port_file) {
1584     return fgetc(pt->rep.stdio.file);
1585   } else {
1586     if(*pt->rep.string.curr == 0 ||
1587        pt->rep.string.curr == pt->rep.string.past_the_end) {
1588       return EOF;
1589     } else {
1590       return *pt->rep.string.curr++;
1591     }
1592   }
1593 }
1594
1595 /* back character to input buffer */
1596 static void backchar(scheme *sc, int c) {
1597   port *pt;
1598   if(c==EOF) return;
1599   pt=sc->inport->_object._port;
1600   if(pt->kind&port_file) {
1601     ungetc(c,pt->rep.stdio.file);
1602   } else {
1603     if(pt->rep.string.curr!=pt->rep.string.start) {
1604       --pt->rep.string.curr;
1605     }
1606   }
1607 }
1608
1609 static int realloc_port_string(scheme *sc, port *p)
1610 {
1611   char *start=p->rep.string.start;
1612   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1613   char *str=sc->malloc(new_size);
1614   if(str) {
1615     memset(str,' ',new_size-1);
1616     str[new_size-1]='\0';
1617     strcpy(str,start);
1618     p->rep.string.start=str;
1619     p->rep.string.past_the_end=str+new_size-1;
1620     p->rep.string.curr-=start-str;
1621     sc->free(start);
1622     return 1;
1623   } else {
1624     return 0;
1625   }
1626 }
1627
1628 INTERFACE void putstr(scheme *sc, const char *s) {
1629   port *pt=sc->outport->_object._port;
1630   if(pt->kind&port_file) {
1631     fputs(s,pt->rep.stdio.file);
1632   } else {
1633     for(;*s;s++) {
1634       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1635         *pt->rep.string.curr++=*s;
1636       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1637         *pt->rep.string.curr++=*s;
1638       }
1639     }
1640   }
1641 }
1642
1643 static void putchars(scheme *sc, const char *s, int len) {
1644   port *pt=sc->outport->_object._port;
1645   if(pt->kind&port_file) {
1646     fwrite(s,1,len,pt->rep.stdio.file);
1647   } else {
1648     for(;len;len--) {
1649       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1650         *pt->rep.string.curr++=*s++;
1651       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1652         *pt->rep.string.curr++=*s++;
1653       }
1654     }
1655   }
1656 }
1657
1658 INTERFACE void putcharacter(scheme *sc, int c) {
1659   port *pt=sc->outport->_object._port;
1660   if(pt->kind&port_file) {
1661     fputc(c,pt->rep.stdio.file);
1662   } else {
1663     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1664       *pt->rep.string.curr++=c;
1665     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1666         *pt->rep.string.curr++=c;
1667     }
1668   }
1669 }
1670
1671 /* read characters up to delimiter, but cater to character constants */
1672 static char *readstr_upto(scheme *sc, char *delim) {
1673   char *p = sc->strbuff;
1674
1675   while ((p - sc->strbuff < sc->strbuff_size) &&
1676          !is_one_of(delim, (*p++ = inchar(sc))));
1677
1678   if(p == sc->strbuff+2 && p[-2] == '\\') {
1679     *p=0;
1680   } else {
1681     backchar(sc,p[-1]);
1682     *--p = '\0';
1683   }
1684   return sc->strbuff;
1685 }
1686
1687 /* read string expression "xxx...xxx" */
1688 static pointer readstrexp(scheme *sc) {
1689   char *p = sc->strbuff;
1690   int c;
1691   int c1=0;
1692   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1693
1694   for (;;) {
1695     c=inchar(sc);
1696     if(c == EOF) {
1697       return sc->F;
1698     }
1699     if(p-sc->strbuff > (sc->strbuff_size)-1) {
1700       ptrdiff_t offset = p - sc->strbuff;
1701       if (expand_strbuff(sc) != 0) {
1702         return sc->F;
1703       }
1704       p = sc->strbuff + offset;
1705     }
1706     switch(state) {
1707         case st_ok:
1708             switch(c) {
1709                 case '\\':
1710                     state=st_bsl;
1711                     break;
1712                 case '"':
1713                     *p=0;
1714                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1715                 default:
1716                     *p++=c;
1717                     break;
1718             }
1719             break;
1720         case st_bsl:
1721             switch(c) {
1722                 case '0':
1723                 case '1':
1724                 case '2':
1725                 case '3':
1726                 case '4':
1727                 case '5':
1728                 case '6':
1729                 case '7':
1730                         state=st_oct1;
1731                         c1=c-'0';
1732                         break;
1733                 case 'x':
1734                 case 'X':
1735                     state=st_x1;
1736                     c1=0;
1737                     break;
1738                 case 'n':
1739                     *p++='\n';
1740                     state=st_ok;
1741                     break;
1742                 case 't':
1743                     *p++='\t';
1744                     state=st_ok;
1745                     break;
1746                 case 'r':
1747                     *p++='\r';
1748                     state=st_ok;
1749                     break;
1750                 case '"':
1751                     *p++='"';
1752                     state=st_ok;
1753                     break;
1754                 default:
1755                     *p++=c;
1756                     state=st_ok;
1757                     break;
1758             }
1759             break;
1760         case st_x1:
1761         case st_x2:
1762             c=toupper(c);
1763             if(c>='0' && c<='F') {
1764                 if(c<='9') {
1765                     c1=(c1<<4)+c-'0';
1766                 } else {
1767                     c1=(c1<<4)+c-'A'+10;
1768                 }
1769                 if(state==st_x1) {
1770                     state=st_x2;
1771                 } else {
1772                     *p++=c1;
1773                     state=st_ok;
1774                 }
1775             } else {
1776                 return sc->F;
1777             }
1778             break;
1779         case st_oct1:
1780         case st_oct2:
1781             if (c < '0' || c > '7')
1782             {
1783                    *p++=c1;
1784                    backchar(sc, c);
1785                    state=st_ok;
1786             }
1787             else
1788             {
1789                 if (state==st_oct2 && c1 >= 32)
1790                     return sc->F;
1791
1792                    c1=(c1<<3)+(c-'0');
1793
1794                 if (state == st_oct1)
1795                         state=st_oct2;
1796                 else
1797                 {
1798                         *p++=c1;
1799                         state=st_ok;
1800                    }
1801             }
1802             break;
1803
1804     }
1805   }
1806 }
1807
1808 /* check c is in chars */
1809 static INLINE int is_one_of(char *s, int c) {
1810      if(c==EOF) return 1;
1811      while (*s)
1812           if (*s++ == c)
1813                return (1);
1814      return (0);
1815 }
1816
1817 /* skip white characters */
1818 static INLINE int skipspace(scheme *sc) {
1819      int c = 0, curr_line = 0;
1820
1821      do {
1822          c=inchar(sc);
1823 #if SHOW_ERROR_LINE
1824          if(c=='\n')
1825            curr_line++;
1826 #endif
1827      } while (isspace(c));
1828
1829 /* record it */
1830 #if SHOW_ERROR_LINE
1831      if (sc->load_stack[sc->file_i].kind & port_file)
1832        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
1833 #endif
1834
1835      if(c!=EOF) {
1836           backchar(sc,c);
1837       return 1;
1838      }
1839      else
1840        { return EOF; }
1841 }
1842
1843 /* get token */
1844 static int token(scheme *sc) {
1845      int c;
1846      c = skipspace(sc);
1847      if(c == EOF) { return (TOK_EOF); }
1848      switch (c=inchar(sc)) {
1849      case EOF:
1850           return (TOK_EOF);
1851      case '(':
1852           return (TOK_LPAREN);
1853      case ')':
1854           return (TOK_RPAREN);
1855      case '.':
1856           c=inchar(sc);
1857           if(is_one_of(" \n\t",c)) {
1858                return (TOK_DOT);
1859           } else {
1860                backchar(sc,c);
1861                backchar(sc,'.');
1862                return TOK_ATOM;
1863           }
1864      case '\'':
1865           return (TOK_QUOTE);
1866      case ';':
1867            while ((c=inchar(sc)) != '\n' && c!=EOF)
1868              ;
1869
1870 #if SHOW_ERROR_LINE
1871            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1872              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1873 #endif
1874
1875        if(c == EOF)
1876          { return (TOK_EOF); }
1877        else
1878          { return (token(sc));}
1879      case '"':
1880           return (TOK_DQUOTE);
1881      case BACKQUOTE:
1882           return (TOK_BQUOTE);
1883      case ',':
1884          if ((c=inchar(sc)) == '@') {
1885                return (TOK_ATMARK);
1886          } else {
1887                backchar(sc,c);
1888                return (TOK_COMMA);
1889          }
1890      case '#':
1891           c=inchar(sc);
1892           if (c == '(') {
1893                return (TOK_VEC);
1894           } else if(c == '!') {
1895                while ((c=inchar(sc)) != '\n' && c!=EOF)
1896                    ;
1897
1898 #if SHOW_ERROR_LINE
1899            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1900              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1901 #endif
1902
1903            if(c == EOF)
1904              { return (TOK_EOF); }
1905            else
1906              { return (token(sc));}
1907           } else {
1908                backchar(sc,c);
1909                if(is_one_of(" tfodxb\\",c)) {
1910                     return TOK_SHARP_CONST;
1911                } else {
1912                     return (TOK_SHARP);
1913                }
1914           }
1915      default:
1916           backchar(sc,c);
1917           return (TOK_ATOM);
1918      }
1919 }
1920
1921 /* ========== Routines for Printing ========== */
1922 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
1923
1924 static void printslashstring(scheme *sc, char *p, int len) {
1925   int i;
1926   unsigned char *s=(unsigned char*)p;
1927   putcharacter(sc,'"');
1928   for ( i=0; i<len; i++) {
1929     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
1930       putcharacter(sc,'\\');
1931       switch(*s) {
1932       case '"':
1933         putcharacter(sc,'"');
1934         break;
1935       case '\n':
1936         putcharacter(sc,'n');
1937         break;
1938       case '\t':
1939         putcharacter(sc,'t');
1940         break;
1941       case '\r':
1942         putcharacter(sc,'r');
1943         break;
1944       case '\\':
1945         putcharacter(sc,'\\');
1946         break;
1947       default: {
1948           int d=*s/16;
1949           putcharacter(sc,'x');
1950           if(d<10) {
1951             putcharacter(sc,d+'0');
1952           } else {
1953             putcharacter(sc,d-10+'A');
1954           }
1955           d=*s%16;
1956           if(d<10) {
1957             putcharacter(sc,d+'0');
1958           } else {
1959             putcharacter(sc,d-10+'A');
1960           }
1961         }
1962       }
1963     } else {
1964       putcharacter(sc,*s);
1965     }
1966     s++;
1967   }
1968   putcharacter(sc,'"');
1969 }
1970
1971
1972 /* print atoms */
1973 static void printatom(scheme *sc, pointer l, int f) {
1974   char *p;
1975   int len;
1976   atom2str(sc,l,f,&p,&len);
1977   putchars(sc,p,len);
1978 }
1979
1980
1981 /* Uses internal buffer unless string pointer is already available */
1982 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
1983      char *p;
1984
1985      if (l == sc->NIL) {
1986           p = "()";
1987      } else if (l == sc->T) {
1988           p = "#t";
1989      } else if (l == sc->F) {
1990           p = "#f";
1991      } else if (l == sc->EOF_OBJ) {
1992           p = "#<EOF>";
1993      } else if (is_port(l)) {
1994           p = "#<PORT>";
1995      } else if (is_number(l)) {
1996           p = sc->strbuff;
1997           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
1998               if(num_is_integer(l)) {
1999                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
2000               } else {
2001                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
2002                    /* r5rs says there must be a '.' (unless 'e'?) */
2003                    f = strcspn(p, ".e");
2004                    if (p[f] == 0) {
2005                         p[f] = '.'; /* not found, so add '.0' at the end */
2006                         p[f+1] = '0';
2007                         p[f+2] = 0;
2008                    }
2009               }
2010           } else {
2011               long v = ivalue(l);
2012               if (f == 16) {
2013                   if (v >= 0)
2014                     snprintf(p, STRBUFFSIZE, "%lx", v);
2015                   else
2016                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
2017               } else if (f == 8) {
2018                   if (v >= 0)
2019                     snprintf(p, STRBUFFSIZE, "%lo", v);
2020                   else
2021                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
2022               } else if (f == 2) {
2023                   unsigned long b = (v < 0) ? -v : v;
2024                   p = &p[STRBUFFSIZE-1];
2025                   *p = 0;
2026                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
2027                   if (v < 0) *--p = '-';
2028               }
2029           }
2030      } else if (is_string(l)) {
2031           if (!f) {
2032                p = strvalue(l);
2033           } else { /* Hack, uses the fact that printing is needed */
2034                *pp=sc->strbuff;
2035                *plen=0;
2036                printslashstring(sc, strvalue(l), strlength(l));
2037                return;
2038           }
2039      } else if (is_character(l)) {
2040           int c=charvalue(l);
2041           p = sc->strbuff;
2042           if (!f) {
2043                p[0]=c;
2044                p[1]=0;
2045           } else {
2046                switch(c) {
2047                case ' ':
2048                     p = "#\\space";
2049                     break;
2050                case '\n':
2051                     p = "#\\newline";
2052                     break;
2053                case '\r':
2054                     p = "#\\return";
2055                     break;
2056                case '\t':
2057                     p = "#\\tab";
2058                     break;
2059                default:
2060 #if USE_ASCII_NAMES
2061                     if(c==127) {
2062                          p = "#\\del";
2063                          break;
2064                     } else if(c<32) {
2065                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
2066                          break;
2067                     }
2068 #else
2069                     if(c<32) {
2070                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2071                       break;
2072                     }
2073 #endif
2074                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2075                     break;
2076                }
2077           }
2078      } else if (is_symbol(l)) {
2079           p = symname(l);
2080      } else if (is_proc(l)) {
2081           p = sc->strbuff;
2082           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2083      } else if (is_macro(l)) {
2084           p = "#<MACRO>";
2085      } else if (is_closure(l)) {
2086           p = "#<CLOSURE>";
2087      } else if (is_promise(l)) {
2088           p = "#<PROMISE>";
2089      } else if (is_foreign(l)) {
2090           p = sc->strbuff;
2091           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2092      } else if (is_continuation(l)) {
2093           p = "#<CONTINUATION>";
2094      } else if (is_foreign_object(l)) {
2095           p = sc->strbuff;
2096           l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
2097      } else {
2098           p = "#<ERROR>";
2099      }
2100      *pp=p;
2101      *plen=strlen(p);
2102 }
2103 /* ========== Routines for Evaluation Cycle ========== */
2104
2105 /* make closure. c is code. e is environment */
2106 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2107      pointer x = get_cell(sc, c, e);
2108
2109      typeflag(x) = T_CLOSURE;
2110      car(x) = c;
2111      cdr(x) = e;
2112      return (x);
2113 }
2114
2115 /* make continuation. */
2116 static pointer mk_continuation(scheme *sc, pointer d) {
2117      pointer x = get_cell(sc, sc->NIL, d);
2118
2119      typeflag(x) = T_CONTINUATION;
2120      cont_dump(x) = d;
2121      return (x);
2122 }
2123
2124 static pointer list_star(scheme *sc, pointer d) {
2125   pointer p, q;
2126   if(cdr(d)==sc->NIL) {
2127     return car(d);
2128   }
2129   p=cons(sc,car(d),cdr(d));
2130   q=p;
2131   while(cdr(cdr(p))!=sc->NIL) {
2132     d=cons(sc,car(p),cdr(p));
2133     if(cdr(cdr(p))!=sc->NIL) {
2134       p=cdr(d);
2135     }
2136   }
2137   cdr(p)=car(cdr(p));
2138   return q;
2139 }
2140
2141 /* reverse list -- produce new list */
2142 static pointer reverse(scheme *sc, pointer a) {
2143 /* a must be checked by gc */
2144      pointer p = sc->NIL;
2145
2146      for ( ; is_pair(a); a = cdr(a)) {
2147           p = cons(sc, car(a), p);
2148      }
2149      return (p);
2150 }
2151
2152 /* reverse list --- in-place */
2153 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2154      pointer p = list, result = term, q;
2155
2156      while (p != sc->NIL) {
2157           q = cdr(p);
2158           cdr(p) = result;
2159           result = p;
2160           p = q;
2161      }
2162      return (result);
2163 }
2164
2165 /* append list -- produce new list (in reverse order) */
2166 static pointer revappend(scheme *sc, pointer a, pointer b) {
2167     pointer result = a;
2168     pointer p = b;
2169
2170     while (is_pair(p)) {
2171         result = cons(sc, car(p), result);
2172         p = cdr(p);
2173     }
2174
2175     if (p == sc->NIL) {
2176         return result;
2177     }
2178
2179     return sc->F;   /* signal an error */
2180 }
2181
2182 /* equivalence of atoms */
2183 int eqv(pointer a, pointer b) {
2184      if (is_string(a)) {
2185           if (is_string(b))
2186                return (strvalue(a) == strvalue(b));
2187           else
2188                return (0);
2189      } else if (is_number(a)) {
2190           if (is_number(b)) {
2191                if (num_is_integer(a) == num_is_integer(b))
2192                     return num_eq(nvalue(a),nvalue(b));
2193           }
2194           return (0);
2195      } else if (is_character(a)) {
2196           if (is_character(b))
2197                return charvalue(a)==charvalue(b);
2198           else
2199                return (0);
2200      } else if (is_port(a)) {
2201           if (is_port(b))
2202                return a==b;
2203           else
2204                return (0);
2205      } else if (is_proc(a)) {
2206           if (is_proc(b))
2207                return procnum(a)==procnum(b);
2208           else
2209                return (0);
2210      } else {
2211           return (a == b);
2212      }
2213 }
2214
2215 /* true or false value macro */
2216 /* () is #t in R5RS */
2217 #define is_true(p)       ((p) != sc->F)
2218 #define is_false(p)      ((p) == sc->F)
2219
2220 /* ========== Environment implementation  ========== */
2221
2222 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2223
2224 static int hash_fn(const char *key, int table_size)
2225 {
2226   unsigned int hashed = 0;
2227   const char *c;
2228   int bits_per_int = sizeof(unsigned int)*8;
2229
2230   for (c = key; *c; c++) {
2231     /* letters have about 5 bits in them */
2232     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2233     hashed ^= *c;
2234   }
2235   return hashed % table_size;
2236 }
2237 #endif
2238
2239 #ifndef USE_ALIST_ENV
2240
2241 /*
2242  * In this implementation, each frame of the environment may be
2243  * a hash table: a vector of alists hashed by variable name.
2244  * In practice, we use a vector only for the initial frame;
2245  * subsequent frames are too small and transient for the lookup
2246  * speed to out-weigh the cost of making a new vector.
2247  */
2248
2249 static void new_frame_in_env(scheme *sc, pointer old_env)
2250 {
2251   pointer new_frame;
2252
2253   /* The interaction-environment has about 300 variables in it. */
2254   if (old_env == sc->NIL) {
2255     new_frame = mk_vector(sc, 461);
2256   } else {
2257     new_frame = sc->NIL;
2258   }
2259
2260   sc->envir = immutable_cons(sc, new_frame, old_env);
2261   setenvironment(sc->envir);
2262 }
2263
2264 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2265                                         pointer variable, pointer value)
2266 {
2267   pointer slot = immutable_cons(sc, variable, value);
2268
2269   if (is_vector(car(env))) {
2270     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2271
2272     set_vector_elem(car(env), location,
2273                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2274   } else {
2275     car(env) = immutable_cons(sc, slot, car(env));
2276   }
2277 }
2278
2279 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2280 {
2281   pointer x,y;
2282   int location;
2283
2284   for (x = env; x != sc->NIL; x = cdr(x)) {
2285     if (is_vector(car(x))) {
2286       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2287       y = vector_elem(car(x), location);
2288     } else {
2289       y = car(x);
2290     }
2291     for ( ; y != sc->NIL; y = cdr(y)) {
2292               if (caar(y) == hdl) {
2293                    break;
2294               }
2295          }
2296          if (y != sc->NIL) {
2297               break;
2298          }
2299          if(!all) {
2300            return sc->NIL;
2301          }
2302     }
2303     if (x != sc->NIL) {
2304           return car(y);
2305     }
2306     return sc->NIL;
2307 }
2308
2309 #else /* USE_ALIST_ENV */
2310
2311 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2312 {
2313   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2314   setenvironment(sc->envir);
2315 }
2316
2317 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2318                                         pointer variable, pointer value)
2319 {
2320   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2321 }
2322
2323 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2324 {
2325     pointer x,y;
2326     for (x = env; x != sc->NIL; x = cdr(x)) {
2327          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2328               if (caar(y) == hdl) {
2329                    break;
2330               }
2331          }
2332          if (y != sc->NIL) {
2333               break;
2334          }
2335          if(!all) {
2336            return sc->NIL;
2337          }
2338     }
2339     if (x != sc->NIL) {
2340           return car(y);
2341     }
2342     return sc->NIL;
2343 }
2344
2345 #endif /* USE_ALIST_ENV else */
2346
2347 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2348 {
2349   new_slot_spec_in_env(sc, sc->envir, variable, value);
2350 }
2351
2352 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2353 {
2354   (void)sc;
2355   cdr(slot) = value;
2356 }
2357
2358 static INLINE pointer slot_value_in_env(pointer slot)
2359 {
2360   return cdr(slot);
2361 }
2362
2363 /* ========== Evaluation Cycle ========== */
2364
2365
2366 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2367      const char *str = s;
2368 #if USE_ERROR_HOOK
2369      pointer x;
2370      pointer hdl=sc->ERROR_HOOK;
2371 #endif
2372
2373 #if SHOW_ERROR_LINE
2374      char sbuf[STRBUFFSIZE];
2375
2376      /* make sure error is not in REPL */
2377      if (sc->load_stack[sc->file_i].kind & port_file &&
2378          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2379        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2380        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2381
2382        /* should never happen */
2383        if(!fname) fname = "<unknown>";
2384
2385        /* we started from 0 */
2386        ln++;
2387        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2388
2389        str = (const char*)sbuf;
2390      }
2391 #endif
2392
2393 #if USE_ERROR_HOOK
2394      x=find_slot_in_env(sc,sc->envir,hdl,1);
2395     if (x != sc->NIL) {
2396          if(a!=0) {
2397                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2398          } else {
2399                sc->code = sc->NIL;
2400          }
2401          sc->code = cons(sc, mk_string(sc, str), sc->code);
2402          setimmutable(car(sc->code));
2403          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2404          sc->op = (int)OP_EVAL;
2405          return sc->T;
2406     }
2407 #endif
2408
2409     if(a!=0) {
2410           sc->args = cons(sc, (a), sc->NIL);
2411     } else {
2412           sc->args = sc->NIL;
2413     }
2414     sc->args = cons(sc, mk_string(sc, str), sc->args);
2415     setimmutable(car(sc->args));
2416     sc->op = (int)OP_ERR0;
2417     return sc->T;
2418 }
2419 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2420 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2421
2422 /* Too small to turn into function */
2423 # define  BEGIN     do {
2424 # define  END  } while (0)
2425 #define s_goto(sc,a) BEGIN                                  \
2426     sc->op = (int)(a);                                      \
2427     return sc->T; END
2428
2429 #define s_return(sc,a) return _s_return(sc,a)
2430
2431 #ifndef USE_SCHEME_STACK
2432
2433 /* this structure holds all the interpreter's registers */
2434 struct dump_stack_frame {
2435   enum scheme_opcodes op;
2436   pointer args;
2437   pointer envir;
2438   pointer code;
2439 };
2440
2441 #define STACK_GROWTH 3
2442
2443 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
2444 {
2445   int nframes = (int)sc->dump;
2446   struct dump_stack_frame *next_frame;
2447
2448   /* enough room for the next frame? */
2449   if (nframes >= sc->dump_size) {
2450     sc->dump_size += STACK_GROWTH;
2451     /* alas there is no sc->realloc */
2452     sc->dump_base = realloc(sc->dump_base,
2453                             sizeof(struct dump_stack_frame) * sc->dump_size);
2454   }
2455   next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2456   next_frame->op = op;
2457   next_frame->args = args;
2458   next_frame->envir = sc->envir;
2459   next_frame->code = code;
2460   sc->dump = (pointer)(nframes+1);
2461 }
2462
2463 static pointer _s_return(scheme *sc, pointer a)
2464 {
2465   int nframes = (int)sc->dump;
2466   struct dump_stack_frame *frame;
2467
2468   sc->value = (a);
2469   if (nframes <= 0) {
2470     return sc->NIL;
2471   }
2472   nframes--;
2473   frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2474   sc->op = frame->op;
2475   sc->args = frame->args;
2476   sc->envir = frame->envir;
2477   sc->code = frame->code;
2478   sc->dump = (pointer)nframes;
2479   return sc->T;
2480 }
2481
2482 static INLINE void dump_stack_reset(scheme *sc)
2483 {
2484   /* in this implementation, sc->dump is the number of frames on the stack */
2485   sc->dump = (pointer)0;
2486 }
2487
2488 static INLINE void dump_stack_initialize(scheme *sc)
2489 {
2490   sc->dump_size = 0;
2491   sc->dump_base = NULL;
2492   dump_stack_reset(sc);
2493 }
2494
2495 static void dump_stack_free(scheme *sc)
2496 {
2497   free(sc->dump_base);
2498   sc->dump_base = NULL;
2499   sc->dump = (pointer)0;
2500   sc->dump_size = 0;
2501 }
2502
2503 static INLINE void dump_stack_mark(scheme *sc)
2504 {
2505   int nframes = (int)sc->dump;
2506   int i;
2507   for(i=0; i<nframes; i++) {
2508     struct dump_stack_frame *frame;
2509     frame = (struct dump_stack_frame *)sc->dump_base + i;
2510     mark(frame->args);
2511     mark(frame->envir);
2512     mark(frame->code);
2513   }
2514 }
2515
2516 #else
2517
2518 static INLINE void dump_stack_reset(scheme *sc)
2519 {
2520   sc->dump = sc->NIL;
2521 }
2522
2523 static INLINE void dump_stack_initialize(scheme *sc)
2524 {
2525   dump_stack_reset(sc);
2526 }
2527
2528 static void dump_stack_free(scheme *sc)
2529 {
2530   sc->dump = sc->NIL;
2531 }
2532
2533 static pointer _s_return(scheme *sc, pointer a) {
2534     sc->value = (a);
2535     if(sc->dump==sc->NIL) return sc->NIL;
2536     sc->op = ivalue(car(sc->dump));
2537     sc->args = cadr(sc->dump);
2538     sc->envir = caddr(sc->dump);
2539     sc->code = cadddr(sc->dump);
2540     sc->dump = cddddr(sc->dump);
2541     return sc->T;
2542 }
2543
2544 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2545     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2546     sc->dump = cons(sc, (args), sc->dump);
2547     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2548 }
2549
2550 static INLINE void dump_stack_mark(scheme *sc)
2551 {
2552   mark(sc->dump);
2553 }
2554 #endif
2555
2556 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
2557
2558 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2559      pointer x, y;
2560
2561      switch (op) {
2562      case OP_LOAD:       /* load */
2563           if(file_interactive(sc)) {
2564                fprintf(sc->outport->_object._port->rep.stdio.file,
2565                "Loading %s\n", strvalue(car(sc->args)));
2566           }
2567           if (!file_push(sc,strvalue(car(sc->args)))) {
2568                Error_1(sc,"unable to open", car(sc->args));
2569           }
2570       else
2571         {
2572           sc->args = mk_integer(sc,sc->file_i);
2573           s_goto(sc,OP_T0LVL);
2574         }
2575
2576      case OP_T0LVL: /* top level */
2577        /* If we reached the end of file, this loop is done. */
2578        if(sc->loadport->_object._port->kind & port_saw_EOF)
2579      {
2580        if(sc->file_i == 0)
2581          {
2582            sc->args=sc->NIL;
2583            s_goto(sc,OP_QUIT);
2584          }
2585        else
2586          {
2587            file_pop(sc);
2588            s_return(sc,sc->value);
2589          }
2590        /* NOTREACHED */
2591      }
2592
2593        /* If interactive, be nice to user. */
2594        if(file_interactive(sc))
2595      {
2596        sc->envir = sc->global_env;
2597        dump_stack_reset(sc);
2598        putstr(sc,"\n");
2599        putstr(sc,prompt);
2600      }
2601
2602        /* Set up another iteration of REPL */
2603        sc->nesting=0;
2604        sc->save_inport=sc->inport;
2605        sc->inport = sc->loadport;
2606        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2607        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2608        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2609        s_goto(sc,OP_READ_INTERNAL);
2610
2611      case OP_T1LVL: /* top level */
2612           sc->code = sc->value;
2613           sc->inport=sc->save_inport;
2614           s_goto(sc,OP_EVAL);
2615
2616      case OP_READ_INTERNAL:       /* internal read */
2617           sc->tok = token(sc);
2618           if(sc->tok==TOK_EOF)
2619         { s_return(sc,sc->EOF_OBJ); }
2620           s_goto(sc,OP_RDSEXPR);
2621
2622      case OP_GENSYM:
2623           s_return(sc, gensym(sc));
2624
2625      case OP_VALUEPRINT: /* print evaluation result */
2626           /* OP_VALUEPRINT is always pushed, because when changing from
2627              non-interactive to interactive mode, it needs to be
2628              already on the stack */
2629        if(sc->tracing) {
2630          putstr(sc,"\nGives: ");
2631        }
2632        if(file_interactive(sc)) {
2633          sc->print_flag = 1;
2634          sc->args = sc->value;
2635          s_goto(sc,OP_P0LIST);
2636        } else {
2637          s_return(sc,sc->value);
2638        }
2639
2640      case OP_EVAL:       /* main part of evaluation */
2641 #if USE_TRACING
2642        if(sc->tracing) {
2643          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2644          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2645          sc->args=sc->code;
2646          putstr(sc,"\nEval: ");
2647          s_goto(sc,OP_P0LIST);
2648        }
2649        /* fall through */
2650      case OP_REAL_EVAL:
2651 #endif
2652           if (is_symbol(sc->code)) {    /* symbol */
2653                x=find_slot_in_env(sc,sc->envir,sc->code,1);
2654                if (x != sc->NIL) {
2655                     s_return(sc,slot_value_in_env(x));
2656                } else {
2657                     Error_1(sc,"eval: unbound variable:", sc->code);
2658                }
2659           } else if (is_pair(sc->code)) {
2660                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
2661                     sc->code = cdr(sc->code);
2662                     s_goto(sc,syntaxnum(x));
2663                } else {/* first, eval top element and eval arguments */
2664                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2665                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2666                     sc->code = car(sc->code);
2667                     s_goto(sc,OP_EVAL);
2668                }
2669           } else {
2670                s_return(sc,sc->code);
2671           }
2672
2673      case OP_E0ARGS:     /* eval arguments */
2674           if (is_macro(sc->value)) {    /* macro expansion */
2675                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2676                sc->args = cons(sc,sc->code, sc->NIL);
2677                sc->code = sc->value;
2678                s_goto(sc,OP_APPLY);
2679           } else {
2680                sc->code = cdr(sc->code);
2681                s_goto(sc,OP_E1ARGS);
2682           }
2683
2684      case OP_E1ARGS:     /* eval arguments */
2685           sc->args = cons(sc, sc->value, sc->args);
2686           if (is_pair(sc->code)) { /* continue */
2687                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2688                sc->code = car(sc->code);
2689                sc->args = sc->NIL;
2690                s_goto(sc,OP_EVAL);
2691           } else {  /* end */
2692                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2693                sc->code = car(sc->args);
2694                sc->args = cdr(sc->args);
2695                s_goto(sc,OP_APPLY);
2696           }
2697
2698 #if USE_TRACING
2699      case OP_TRACING: {
2700        int tr=sc->tracing;
2701        sc->tracing=ivalue(car(sc->args));
2702        s_return(sc,mk_integer(sc,tr));
2703      }
2704 #endif
2705
2706      case OP_APPLY:      /* apply 'code' to 'args' */
2707 #if USE_TRACING
2708        if(sc->tracing) {
2709          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2710          sc->print_flag = 1;
2711          /*  sc->args=cons(sc,sc->code,sc->args);*/
2712          putstr(sc,"\nApply to: ");
2713          s_goto(sc,OP_P0LIST);
2714        }
2715        /* fall through */
2716      case OP_REAL_APPLY:
2717 #endif
2718           if (is_proc(sc->code)) {
2719                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
2720           } else if (is_foreign(sc->code))
2721             {
2722               /* Keep nested calls from GC'ing the arglist */
2723               push_recent_alloc(sc,sc->args,sc->NIL);
2724                x=sc->code->_object._ff(sc,sc->args);
2725                s_return(sc,x);
2726           } else if (is_closure(sc->code) || is_macro(sc->code)
2727              || is_promise(sc->code)) { /* CLOSURE */
2728         /* Should not accept promise */
2729                /* make environment */
2730                new_frame_in_env(sc, closure_env(sc->code));
2731                for (x = car(closure_code(sc->code)), y = sc->args;
2732                     is_pair(x); x = cdr(x), y = cdr(y)) {
2733                     if (y == sc->NIL) {
2734                          Error_0(sc,"not enough arguments");
2735                     } else {
2736                          new_slot_in_env(sc, car(x), car(y));
2737                     }
2738                }
2739                if (x == sc->NIL) {
2740                     /*--
2741                      * if (y != sc->NIL) {
2742                      *   Error_0(sc,"too many arguments");
2743                      * }
2744                      */
2745                } else if (is_symbol(x))
2746                     new_slot_in_env(sc, x, y);
2747                else {
2748                     Error_1(sc,"syntax error in closure: not a symbol:", x);
2749                }
2750                sc->code = cdr(closure_code(sc->code));
2751                sc->args = sc->NIL;
2752                s_goto(sc,OP_BEGIN);
2753           } else if (is_continuation(sc->code)) { /* CONTINUATION */
2754                sc->dump = cont_dump(sc->code);
2755                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2756           } else {
2757                Error_1(sc,"illegal function",sc->code);
2758           }
2759
2760      case OP_DOMACRO:    /* do macro */
2761           sc->code = sc->value;
2762           s_goto(sc,OP_EVAL);
2763
2764 #if 1
2765      case OP_LAMBDA:     /* lambda */
2766           /* If the hook is defined, apply it to sc->code, otherwise
2767              set sc->value fall thru */
2768           {
2769                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2770                if(f==sc->NIL) {
2771                     sc->value = sc->code;
2772                     /* Fallthru */
2773                } else {
2774                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2775                     sc->args=cons(sc,sc->code,sc->NIL);
2776                     sc->code=slot_value_in_env(f);
2777                     s_goto(sc,OP_APPLY);
2778                }
2779           }
2780
2781      case OP_LAMBDA1:
2782           s_return(sc,mk_closure(sc, sc->value, sc->envir));
2783
2784 #else
2785      case OP_LAMBDA:     /* lambda */
2786           s_return(sc,mk_closure(sc, sc->code, sc->envir));
2787
2788 #endif
2789
2790      case OP_MKCLOSURE: /* make-closure */
2791        x=car(sc->args);
2792        if(car(x)==sc->LAMBDA) {
2793          x=cdr(x);
2794        }
2795        if(cdr(sc->args)==sc->NIL) {
2796          y=sc->envir;
2797        } else {
2798          y=cadr(sc->args);
2799        }
2800        s_return(sc,mk_closure(sc, x, y));
2801
2802      case OP_QUOTE:      /* quote */
2803           s_return(sc,car(sc->code));
2804
2805      case OP_DEF0:  /* define */
2806           if(is_immutable(car(sc->code)))
2807             Error_1(sc,"define: unable to alter immutable", car(sc->code));
2808
2809           if (is_pair(car(sc->code))) {
2810                x = caar(sc->code);
2811                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2812           } else {
2813                x = car(sc->code);
2814                sc->code = cadr(sc->code);
2815           }
2816           if (!is_symbol(x)) {
2817                Error_0(sc,"variable is not a symbol");
2818           }
2819           s_save(sc,OP_DEF1, sc->NIL, x);
2820           s_goto(sc,OP_EVAL);
2821
2822      case OP_DEF1:  /* define */
2823           x=find_slot_in_env(sc,sc->envir,sc->code,0);
2824           if (x != sc->NIL) {
2825                set_slot_in_env(sc, x, sc->value);
2826           } else {
2827                new_slot_in_env(sc, sc->code, sc->value);
2828           }
2829           s_return(sc,sc->code);
2830
2831
2832      case OP_DEFP:  /* defined? */
2833           x=sc->envir;
2834           if(cdr(sc->args)!=sc->NIL) {
2835                x=cadr(sc->args);
2836           }
2837           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2838
2839      case OP_SET0:       /* set! */
2840           if(is_immutable(car(sc->code)))
2841                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
2842           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2843           sc->code = cadr(sc->code);
2844           s_goto(sc,OP_EVAL);
2845
2846      case OP_SET1:       /* set! */
2847           y=find_slot_in_env(sc,sc->envir,sc->code,1);
2848           if (y != sc->NIL) {
2849                set_slot_in_env(sc, y, sc->value);
2850                s_return(sc,sc->value);
2851           } else {
2852                Error_1(sc,"set!: unbound variable:", sc->code);
2853           }
2854
2855
2856      case OP_BEGIN:      /* begin */
2857           if (!is_pair(sc->code)) {
2858                s_return(sc,sc->code);
2859           }
2860           if (cdr(sc->code) != sc->NIL) {
2861                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2862           }
2863           sc->code = car(sc->code);
2864           s_goto(sc,OP_EVAL);
2865
2866      case OP_IF0:        /* if */
2867           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2868           sc->code = car(sc->code);
2869           s_goto(sc,OP_EVAL);
2870
2871      case OP_IF1:        /* if */
2872           if (is_true(sc->value))
2873                sc->code = car(sc->code);
2874           else
2875                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
2876                                             * car(sc->NIL) = sc->NIL */
2877           s_goto(sc,OP_EVAL);
2878
2879      case OP_LET0:       /* let */
2880           sc->args = sc->NIL;
2881           sc->value = sc->code;
2882           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2883           s_goto(sc,OP_LET1);
2884
2885      case OP_LET1:       /* let (calculate parameters) */
2886           sc->args = cons(sc, sc->value, sc->args);
2887           if (is_pair(sc->code)) { /* continue */
2888                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2889                     Error_1(sc, "Bad syntax of binding spec in let :",
2890                             car(sc->code));
2891                }
2892                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2893                sc->code = cadar(sc->code);
2894                sc->args = sc->NIL;
2895                s_goto(sc,OP_EVAL);
2896           } else {  /* end */
2897                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2898                sc->code = car(sc->args);
2899                sc->args = cdr(sc->args);
2900                s_goto(sc,OP_LET2);
2901           }
2902
2903      case OP_LET2:       /* let */
2904           new_frame_in_env(sc, sc->envir);
2905           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2906                y != sc->NIL; x = cdr(x), y = cdr(y)) {
2907                new_slot_in_env(sc, caar(x), car(y));
2908           }
2909           if (is_symbol(car(sc->code))) {    /* named let */
2910                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2911                     if (!is_pair(x))
2912                         Error_1(sc, "Bad syntax of binding in let :", x);
2913                     if (!is_list(sc, car(x)))
2914                         Error_1(sc, "Bad syntax of binding in let :", car(x));
2915                     sc->args = cons(sc, caar(x), sc->args);
2916                }
2917                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2918                new_slot_in_env(sc, car(sc->code), x);
2919                sc->code = cddr(sc->code);
2920                sc->args = sc->NIL;
2921           } else {
2922                sc->code = cdr(sc->code);
2923                sc->args = sc->NIL;
2924           }
2925           s_goto(sc,OP_BEGIN);
2926
2927      case OP_LET0AST:    /* let* */
2928           if (car(sc->code) == sc->NIL) {
2929                new_frame_in_env(sc, sc->envir);
2930                sc->code = cdr(sc->code);
2931                s_goto(sc,OP_BEGIN);
2932           }
2933           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
2934                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
2935           }
2936           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2937           sc->code = cadaar(sc->code);
2938           s_goto(sc,OP_EVAL);
2939
2940      case OP_LET1AST:    /* let* (make new frame) */
2941           new_frame_in_env(sc, sc->envir);
2942           s_goto(sc,OP_LET2AST);
2943
2944      case OP_LET2AST:    /* let* (calculate parameters) */
2945           new_slot_in_env(sc, caar(sc->code), sc->value);
2946           sc->code = cdr(sc->code);
2947           if (is_pair(sc->code)) { /* continue */
2948                s_save(sc,OP_LET2AST, sc->args, sc->code);
2949                sc->code = cadar(sc->code);
2950                sc->args = sc->NIL;
2951                s_goto(sc,OP_EVAL);
2952           } else {  /* end */
2953                sc->code = sc->args;
2954                sc->args = sc->NIL;
2955                s_goto(sc,OP_BEGIN);
2956           }
2957      default:
2958           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
2959           Error_0(sc,sc->strbuff);
2960      }
2961      return sc->T;
2962 }
2963
2964 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2965      pointer x, y;
2966
2967      switch (op) {
2968      case OP_LET0REC:    /* letrec */
2969           new_frame_in_env(sc, sc->envir);
2970           sc->args = sc->NIL;
2971           sc->value = sc->code;
2972           sc->code = car(sc->code);
2973           s_goto(sc,OP_LET1REC);
2974
2975      case OP_LET1REC:    /* letrec (calculate parameters) */
2976           sc->args = cons(sc, sc->value, sc->args);
2977           if (is_pair(sc->code)) { /* continue */
2978                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2979                     Error_1(sc, "Bad syntax of binding spec in letrec :",
2980                             car(sc->code));
2981                }
2982                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2983                sc->code = cadar(sc->code);
2984                sc->args = sc->NIL;
2985                s_goto(sc,OP_EVAL);
2986           } else {  /* end */
2987                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2988                sc->code = car(sc->args);
2989                sc->args = cdr(sc->args);
2990                s_goto(sc,OP_LET2REC);
2991           }
2992
2993      case OP_LET2REC:    /* letrec */
2994           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2995                new_slot_in_env(sc, caar(x), car(y));
2996           }
2997           sc->code = cdr(sc->code);
2998           sc->args = sc->NIL;
2999           s_goto(sc,OP_BEGIN);
3000
3001      case OP_COND0:      /* cond */
3002           if (!is_pair(sc->code)) {
3003                Error_0(sc,"syntax error in cond");
3004           }
3005           s_save(sc,OP_COND1, sc->NIL, sc->code);
3006           sc->code = caar(sc->code);
3007           s_goto(sc,OP_EVAL);
3008
3009      case OP_COND1:      /* cond */
3010           if (is_true(sc->value)) {
3011                if ((sc->code = cdar(sc->code)) == sc->NIL) {
3012                     s_return(sc,sc->value);
3013                }
3014                if(!sc->code || car(sc->code)==sc->FEED_TO) {
3015                     if(!is_pair(cdr(sc->code))) {
3016                          Error_0(sc,"syntax error in cond");
3017                     }
3018                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
3019                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
3020                     s_goto(sc,OP_EVAL);
3021                }
3022                s_goto(sc,OP_BEGIN);
3023           } else {
3024                if ((sc->code = cdr(sc->code)) == sc->NIL) {
3025                     s_return(sc,sc->NIL);
3026                } else {
3027                     s_save(sc,OP_COND1, sc->NIL, sc->code);
3028                     sc->code = caar(sc->code);
3029                     s_goto(sc,OP_EVAL);
3030                }
3031           }
3032
3033      case OP_DELAY:      /* delay */
3034           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3035           typeflag(x)=T_PROMISE;
3036           s_return(sc,x);
3037
3038      case OP_AND0:       /* and */
3039           if (sc->code == sc->NIL) {
3040                s_return(sc,sc->T);
3041           }
3042           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3043           sc->code = car(sc->code);
3044           s_goto(sc,OP_EVAL);
3045
3046      case OP_AND1:       /* and */
3047           if (is_false(sc->value)) {
3048                s_return(sc,sc->value);
3049           } else if (sc->code == sc->NIL) {
3050                s_return(sc,sc->value);
3051           } else {
3052                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3053                sc->code = car(sc->code);
3054                s_goto(sc,OP_EVAL);
3055           }
3056
3057      case OP_OR0:        /* or */
3058           if (sc->code == sc->NIL) {
3059                s_return(sc,sc->F);
3060           }
3061           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3062           sc->code = car(sc->code);
3063           s_goto(sc,OP_EVAL);
3064
3065      case OP_OR1:        /* or */
3066           if (is_true(sc->value)) {
3067                s_return(sc,sc->value);
3068           } else if (sc->code == sc->NIL) {
3069                s_return(sc,sc->value);
3070           } else {
3071                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3072                sc->code = car(sc->code);
3073                s_goto(sc,OP_EVAL);
3074           }
3075
3076      case OP_C0STREAM:   /* cons-stream */
3077           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3078           sc->code = car(sc->code);
3079           s_goto(sc,OP_EVAL);
3080
3081      case OP_C1STREAM:   /* cons-stream */
3082           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3083           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3084           typeflag(x)=T_PROMISE;
3085           s_return(sc,cons(sc, sc->args, x));
3086
3087      case OP_MACRO0:     /* macro */
3088           if (is_pair(car(sc->code))) {
3089                x = caar(sc->code);
3090                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3091           } else {
3092                x = car(sc->code);
3093                sc->code = cadr(sc->code);
3094           }
3095           if (!is_symbol(x)) {
3096                Error_0(sc,"variable is not a symbol");
3097           }
3098           s_save(sc,OP_MACRO1, sc->NIL, x);
3099           s_goto(sc,OP_EVAL);
3100
3101      case OP_MACRO1:     /* macro */
3102           typeflag(sc->value) = T_MACRO;
3103           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3104           if (x != sc->NIL) {
3105                set_slot_in_env(sc, x, sc->value);
3106           } else {
3107                new_slot_in_env(sc, sc->code, sc->value);
3108           }
3109           s_return(sc,sc->code);
3110
3111      case OP_CASE0:      /* case */
3112           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3113           sc->code = car(sc->code);
3114           s_goto(sc,OP_EVAL);
3115
3116      case OP_CASE1:      /* case */
3117           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3118                if (!is_pair(y = caar(x))) {
3119                     break;
3120                }
3121                for ( ; y != sc->NIL; y = cdr(y)) {
3122                     if (eqv(car(y), sc->value)) {
3123                          break;
3124                     }
3125                }
3126                if (y != sc->NIL) {
3127                     break;
3128                }
3129           }
3130           if (x != sc->NIL) {
3131                if (is_pair(caar(x))) {
3132                     sc->code = cdar(x);
3133                     s_goto(sc,OP_BEGIN);
3134                } else {/* else */
3135                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3136                     sc->code = caar(x);
3137                     s_goto(sc,OP_EVAL);
3138                }
3139           } else {
3140                s_return(sc,sc->NIL);
3141           }
3142
3143      case OP_CASE2:      /* case */
3144           if (is_true(sc->value)) {
3145                s_goto(sc,OP_BEGIN);
3146           } else {
3147                s_return(sc,sc->NIL);
3148           }
3149
3150      case OP_PAPPLY:     /* apply */
3151           sc->code = car(sc->args);
3152           sc->args = list_star(sc,cdr(sc->args));
3153           /*sc->args = cadr(sc->args);*/
3154           s_goto(sc,OP_APPLY);
3155
3156      case OP_PEVAL: /* eval */
3157           if(cdr(sc->args)!=sc->NIL) {
3158                sc->envir=cadr(sc->args);
3159           }
3160           sc->code = car(sc->args);
3161           s_goto(sc,OP_EVAL);
3162
3163      case OP_CONTINUATION:    /* call-with-current-continuation */
3164           sc->code = car(sc->args);
3165           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3166           s_goto(sc,OP_APPLY);
3167
3168      default:
3169           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3170           Error_0(sc,sc->strbuff);
3171      }
3172      return sc->T;
3173 }
3174
3175 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3176      pointer x;
3177      num v;
3178 #if USE_MATH
3179      double dd;
3180 #endif
3181
3182      switch (op) {
3183 #if USE_MATH
3184      case OP_INEX2EX:    /* inexact->exact */
3185           x=car(sc->args);
3186           if(num_is_integer(x)) {
3187                s_return(sc,x);
3188           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3189                s_return(sc,mk_integer(sc,ivalue(x)));
3190           } else {
3191                Error_1(sc,"inexact->exact: not integral:",x);
3192           }
3193
3194      case OP_EXP:
3195           x=car(sc->args);
3196           s_return(sc, mk_real(sc, exp(rvalue(x))));
3197
3198      case OP_LOG:
3199           x=car(sc->args);
3200           s_return(sc, mk_real(sc, log(rvalue(x))));
3201
3202      case OP_SIN:
3203           x=car(sc->args);
3204           s_return(sc, mk_real(sc, sin(rvalue(x))));
3205
3206      case OP_COS:
3207           x=car(sc->args);
3208           s_return(sc, mk_real(sc, cos(rvalue(x))));
3209
3210      case OP_TAN:
3211           x=car(sc->args);
3212           s_return(sc, mk_real(sc, tan(rvalue(x))));
3213
3214      case OP_ASIN:
3215           x=car(sc->args);
3216           s_return(sc, mk_real(sc, asin(rvalue(x))));
3217
3218      case OP_ACOS:
3219           x=car(sc->args);
3220           s_return(sc, mk_real(sc, acos(rvalue(x))));
3221
3222      case OP_ATAN:
3223           x=car(sc->args);
3224           if(cdr(sc->args)==sc->NIL) {
3225                s_return(sc, mk_real(sc, atan(rvalue(x))));
3226           } else {
3227                pointer y=cadr(sc->args);
3228                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3229           }
3230
3231      case OP_SQRT:
3232           x=car(sc->args);
3233           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3234
3235      case OP_EXPT: {
3236           double result;
3237           int real_result=1;
3238           pointer y=cadr(sc->args);
3239           x=car(sc->args);
3240           if (num_is_integer(x) && num_is_integer(y))
3241              real_result=0;
3242           /* This 'if' is an R5RS compatibility fix. */
3243           /* NOTE: Remove this 'if' fix for R6RS.    */
3244           if (rvalue(x) == 0 && rvalue(y) < 0) {
3245              result = 0.0;
3246           } else {
3247              result = pow(rvalue(x),rvalue(y));
3248           }
3249           /* Before returning integer result make sure we can. */
3250           /* If the test fails, result is too big for integer. */
3251           if (!real_result)
3252           {
3253             long result_as_long = (long)result;
3254             if (result != (double)result_as_long)
3255               real_result = 1;
3256           }
3257           if (real_result) {
3258              s_return(sc, mk_real(sc, result));
3259           } else {
3260              s_return(sc, mk_integer(sc, result));
3261           }
3262      }
3263
3264      case OP_FLOOR:
3265           x=car(sc->args);
3266           s_return(sc, mk_real(sc, floor(rvalue(x))));
3267
3268      case OP_CEILING:
3269           x=car(sc->args);
3270           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3271
3272      case OP_TRUNCATE : {
3273           double rvalue_of_x ;
3274           x=car(sc->args);
3275           rvalue_of_x = rvalue(x) ;
3276           if (rvalue_of_x > 0) {
3277             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3278           } else {
3279             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3280           }
3281      }
3282
3283      case OP_ROUND:
3284         x=car(sc->args);
3285         if (num_is_integer(x))
3286             s_return(sc, x);
3287         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3288 #endif
3289
3290      case OP_ADD:        /* + */
3291        v=num_zero;
3292        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3293          v=num_add(v,nvalue(car(x)));
3294        }
3295        s_return(sc,mk_number(sc, v));
3296
3297      case OP_MUL:        /* * */
3298        v=num_one;
3299        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3300          v=num_mul(v,nvalue(car(x)));
3301        }
3302        s_return(sc,mk_number(sc, v));
3303
3304      case OP_SUB:        /* - */
3305        if(cdr(sc->args)==sc->NIL) {
3306          x=sc->args;
3307          v=num_zero;
3308        } else {
3309          x = cdr(sc->args);
3310          v = nvalue(car(sc->args));
3311        }
3312        for (; x != sc->NIL; x = cdr(x)) {
3313          v=num_sub(v,nvalue(car(x)));
3314        }
3315        s_return(sc,mk_number(sc, v));
3316
3317      case OP_DIV:        /* / */
3318        if(cdr(sc->args)==sc->NIL) {
3319          x=sc->args;
3320          v=num_one;
3321        } else {
3322          x = cdr(sc->args);
3323          v = nvalue(car(sc->args));
3324        }
3325        for (; x != sc->NIL; x = cdr(x)) {
3326          if (!is_zero_double(rvalue(car(x))))
3327            v=num_div(v,nvalue(car(x)));
3328          else {
3329            Error_0(sc,"/: division by zero");
3330          }
3331        }
3332        s_return(sc,mk_number(sc, v));
3333
3334      case OP_INTDIV:        /* quotient */
3335           if(cdr(sc->args)==sc->NIL) {
3336                x=sc->args;
3337                v=num_one;
3338           } else {
3339                x = cdr(sc->args);
3340                v = nvalue(car(sc->args));
3341           }
3342           for (; x != sc->NIL; x = cdr(x)) {
3343                if (ivalue(car(x)) != 0)
3344                     v=num_intdiv(v,nvalue(car(x)));
3345                else {
3346                     Error_0(sc,"quotient: division by zero");
3347                }
3348           }
3349           s_return(sc,mk_number(sc, v));
3350
3351      case OP_REM:        /* remainder */
3352           v = nvalue(car(sc->args));
3353           if (ivalue(cadr(sc->args)) != 0)
3354                v=num_rem(v,nvalue(cadr(sc->args)));
3355           else {
3356                Error_0(sc,"remainder: division by zero");
3357           }
3358           s_return(sc,mk_number(sc, v));
3359
3360      case OP_MOD:        /* modulo */
3361           v = nvalue(car(sc->args));
3362           if (ivalue(cadr(sc->args)) != 0)
3363                v=num_mod(v,nvalue(cadr(sc->args)));
3364           else {
3365                Error_0(sc,"modulo: division by zero");
3366           }
3367           s_return(sc,mk_number(sc, v));
3368
3369      case OP_CAR:        /* car */
3370           s_return(sc,caar(sc->args));
3371
3372      case OP_CDR:        /* cdr */
3373           s_return(sc,cdar(sc->args));
3374
3375      case OP_CONS:       /* cons */
3376           cdr(sc->args) = cadr(sc->args);
3377           s_return(sc,sc->args);
3378
3379      case OP_SETCAR:     /* set-car! */
3380        if(!is_immutable(car(sc->args))) {
3381          caar(sc->args) = cadr(sc->args);
3382          s_return(sc,car(sc->args));
3383        } else {
3384          Error_0(sc,"set-car!: unable to alter immutable pair");
3385        }
3386
3387      case OP_SETCDR:     /* set-cdr! */
3388        if(!is_immutable(car(sc->args))) {
3389          cdar(sc->args) = cadr(sc->args);
3390          s_return(sc,car(sc->args));
3391        } else {
3392          Error_0(sc,"set-cdr!: unable to alter immutable pair");
3393        }
3394
3395      case OP_CHAR2INT: { /* char->integer */
3396           char c;
3397           c=(char)ivalue(car(sc->args));
3398           s_return(sc,mk_integer(sc,(unsigned char)c));
3399      }
3400
3401      case OP_INT2CHAR: { /* integer->char */
3402           unsigned char c;
3403           c=(unsigned char)ivalue(car(sc->args));
3404           s_return(sc,mk_character(sc,(char)c));
3405      }
3406
3407      case OP_CHARUPCASE: {
3408           unsigned char c;
3409           c=(unsigned char)ivalue(car(sc->args));
3410           c=toupper(c);
3411           s_return(sc,mk_character(sc,(char)c));
3412      }
3413
3414      case OP_CHARDNCASE: {
3415           unsigned char c;
3416           c=(unsigned char)ivalue(car(sc->args));
3417           c=tolower(c);
3418           s_return(sc,mk_character(sc,(char)c));
3419      }
3420
3421      case OP_STR2SYM:  /* string->symbol */
3422           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3423
3424      case OP_STR2ATOM: /* string->atom */ {
3425           char *s=strvalue(car(sc->args));
3426           long pf = 0;
3427           if(cdr(sc->args)!=sc->NIL) {
3428             /* we know cadr(sc->args) is a natural number */
3429             /* see if it is 2, 8, 10, or 16, or error */
3430             pf = ivalue_unchecked(cadr(sc->args));
3431             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3432                /* base is OK */
3433             }
3434             else {
3435               pf = -1;
3436             }
3437           }
3438           if (pf < 0) {
3439             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3440           } else if(*s=='#') /* no use of base! */ {
3441             s_return(sc, mk_sharp_const(sc, s+1));
3442           } else {
3443             if (pf == 0 || pf == 10) {
3444               s_return(sc, mk_atom(sc, s));
3445             }
3446             else {
3447               char *ep;
3448               long iv = strtol(s,&ep,(int )pf);
3449               if (*ep == 0) {
3450                 s_return(sc, mk_integer(sc, iv));
3451               }
3452               else {
3453                 s_return(sc, sc->F);
3454               }
3455             }
3456           }
3457         }
3458
3459      case OP_SYM2STR: /* symbol->string */
3460           x=mk_string(sc,symname(car(sc->args)));
3461           setimmutable(x);
3462           s_return(sc,x);
3463
3464      case OP_ATOM2STR: /* atom->string */ {
3465           long pf = 0;
3466           x=car(sc->args);
3467           if(cdr(sc->args)!=sc->NIL) {
3468             /* we know cadr(sc->args) is a natural number */
3469             /* see if it is 2, 8, 10, or 16, or error */
3470             pf = ivalue_unchecked(cadr(sc->args));
3471             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
3472               /* base is OK */
3473             }
3474             else {
3475               pf = -1;
3476             }
3477           }
3478           if (pf < 0) {
3479             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
3480           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3481             char *p;
3482             int len;
3483             atom2str(sc,x,(int )pf,&p,&len);
3484             s_return(sc,mk_counted_string(sc,p,len));
3485           } else {
3486             Error_1(sc, "atom->string: not an atom:", x);
3487           }
3488         }
3489
3490      case OP_MKSTRING: { /* make-string */
3491           int fill=' ';
3492           int len;
3493
3494           len=ivalue(car(sc->args));
3495
3496           if(cdr(sc->args)!=sc->NIL) {
3497                fill=charvalue(cadr(sc->args));
3498           }
3499           s_return(sc,mk_empty_string(sc,len,(char)fill));
3500      }
3501
3502      case OP_STRLEN:  /* string-length */
3503           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
3504
3505      case OP_STRREF: { /* string-ref */
3506           char *str;
3507           int index;
3508
3509           str=strvalue(car(sc->args));
3510
3511           index=ivalue(cadr(sc->args));
3512
3513           if(index>=strlength(car(sc->args))) {
3514                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3515           }
3516
3517           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
3518      }
3519
3520      case OP_STRSET: { /* string-set! */
3521           char *str;
3522           int index;
3523           int c;
3524
3525           if(is_immutable(car(sc->args))) {
3526                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3527           }
3528           str=strvalue(car(sc->args));
3529
3530           index=ivalue(cadr(sc->args));
3531           if(index>=strlength(car(sc->args))) {
3532                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3533           }
3534
3535           c=charvalue(caddr(sc->args));
3536
3537           str[index]=(char)c;
3538           s_return(sc,car(sc->args));
3539      }
3540
3541      case OP_STRAPPEND: { /* string-append */
3542        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3543        int len = 0;
3544        pointer newstr;
3545        char *pos;
3546
3547        /* compute needed length for new string */
3548        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3549           len += strlength(car(x));
3550        }
3551        newstr = mk_empty_string(sc, len, ' ');
3552        /* store the contents of the argument strings into the new string */
3553        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3554            pos += strlength(car(x)), x = cdr(x)) {
3555            memcpy(pos, strvalue(car(x)), strlength(car(x)));
3556        }
3557        s_return(sc, newstr);
3558      }
3559
3560      case OP_SUBSTR: { /* substring */
3561           char *str;
3562           int index0;
3563           int index1;
3564           int len;
3565
3566           str=strvalue(car(sc->args));
3567
3568           index0=ivalue(cadr(sc->args));
3569
3570           if(index0>strlength(car(sc->args))) {
3571               &