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