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
15 /** \file scheme.c
16 \brief The TinyScheme compiler
17 \ingroup gerbv
18 */
19
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
stricmp(const char * s1,const char * s2)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
strlwr(char * s)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
is_string(pointer p)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
is_vector(pointer p)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);
is_number(pointer p)184 INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
is_integer(pointer p)185 INTERFACE INLINE int is_integer(pointer p) {
186 return ((p)->_object._number.is_fixnum);
187 }
is_real(pointer p)188 INTERFACE INLINE int is_real(pointer p) {
189 return (!(p)->_object._number.is_fixnum);
190 }
191
is_character(pointer p)192 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
string_value(pointer p)193 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
nvalue(pointer p)194 INLINE num nvalue(pointer p) { return ((p)->_object._number); }
ivalue(pointer p)195 INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
rvalue(pointer p)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;
charvalue(pointer p)201 INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); }
202
is_port(pointer p)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
is_pair(pointer p)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)
pair_car(pointer p)210 INTERFACE pointer pair_car(pointer p) { return car(p); }
pair_cdr(pointer p)211 INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
set_car(pointer p,pointer q)212 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
set_cdr(pointer p,pointer q)213 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
214
is_symbol(pointer p)215 INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
symname(pointer p)216 INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
217 #if USE_PLIST
hasprop(pointer p)218 SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
219 #define symprop(p) cdr(p)
220 #endif
221
is_syntax(pointer p)222 INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
is_proc(pointer p)223 INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
is_foreign(pointer p)224 INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
syntaxname(pointer p)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
is_closure(pointer p)229 INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
is_macro(pointer p)230 INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
closure_code(pointer p)231 INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
closure_env(pointer p)232 INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
233
is_continuation(pointer p)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 */
is_promise(pointer p)238 INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
239
is_environment(pointer p)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
is_immutable(pointer p)251 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
252 /*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
setimmutable(pointer p)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
Cisalpha(int c)266 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
Cisdigit(int c)267 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
Cisspace(int c)268 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
Cisupper(int c)269 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
Cislower(int 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
is_ascii_name(const char * name,int * pc)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
num_add(num a,num b)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
num_mul(num a,num b)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
num_div(num a,num b)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
num_intdiv(num a,num b)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
num_sub(num a,num b)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
num_rem(num a,num b)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
num_mod(num a,num b)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
num_eq(num a,num b)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
num_gt(num a,num b)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
num_ge(num a,num b)507 static int num_ge(num a, num b) {
508 return !num_lt(a,b);
509 }
510
num_lt(num a,num b)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
num_le(num a,num b)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 */
round_per_R5RS(double x)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
is_zero_double(double x)547 static int is_zero_double(double x) {
548 return x<DBL_MIN && x>-DBL_MIN;
549 }
550
binary_decode(const char * s)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 */
alloc_cellseg(scheme * sc,int n)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
get_cell(scheme * sc,pointer a,pointer b)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. */
_get_cell(scheme * sc,pointer a,pointer b)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
get_consecutive_cells(scheme * sc,int n)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
count_consecutive_cells(pointer x,int needed)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
find_consecutive_cells(scheme * sc,int n)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 */
_cons(scheme * sc,pointer a,pointer b,int immutable)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
oblist_initial_value(scheme * sc)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 */
oblist_add_by_name(scheme * sc,const char * name)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
oblist_find_by_name(scheme * sc,const char * name)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
oblist_all_symbols(scheme * sc)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
oblist_initial_value(scheme * sc)786 static pointer oblist_initial_value(scheme *sc)
787 {
788 return sc->NIL;
789 }
790
oblist_find_by_name(scheme * sc,const char * name)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 */
oblist_add_by_name(scheme * sc,const char * name)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 }
oblist_all_symbols(scheme * sc)817 static pointer oblist_all_symbols(scheme *sc)
818 {
819 return sc->oblist;
820 }
821
822 #endif
823
mk_port(scheme * sc,port * p)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
mk_foreign_func(scheme * sc,foreign_func f)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
mk_character(scheme * sc,int c)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) */
mk_integer(scheme * sc,long num)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
mk_real(scheme * sc,double n)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
mk_number(scheme * sc,num n)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 */
store_string(scheme * sc,int len_str,const char * str,char fill)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 */
mk_string(scheme * sc,const char * str)895 INTERFACE pointer mk_string(scheme *sc, const char *str) {
896 return mk_counted_string(sc,str,strlen(str));
897 }
898
mk_counted_string(scheme * sc,const char * str,int len)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
mk_empty_string(scheme * sc,int len,char fill)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
mk_vector(scheme * sc,int len)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
fill_vector(pointer vec,pointer obj)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
vector_elem(pointer vec,int ielem)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
set_vector_elem(pointer vec,int ielem,pointer a)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 */
mk_symbol(scheme * sc,const char * name)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
gensym(scheme * sc)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 */
mk_atom(scheme * sc,char * q)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 */
mk_sharp_const(scheme * sc,char * name)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 */
mark(pointer a)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. */
gc(scheme * sc,pointer a,pointer b)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
finalize_cell(scheme * sc,pointer a)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
file_push(scheme * sc,const char * fname)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
file_pop(scheme * sc)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
file_interactive(scheme * sc)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
port_rep_from_filename(scheme * sc,const char * fn,int prop)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
port_from_filename(scheme * sc,const char * fn,int prop)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
port_rep_from_file(scheme * sc,FILE * f,int prop)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
port_from_file(scheme * sc,FILE * f,int prop)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
port_rep_from_string(scheme * sc,char * start,char * past_the_end,int prop)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
port_from_string(scheme * sc,char * start,char * past_the_end,int prop)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
port_close(scheme * sc,pointer p,int flag)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 */
inchar(scheme * sc)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
basic_inchar(port * pt)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 */
backchar(scheme * sc,int c)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
putstr(scheme * sc,const char * s)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
putchars(scheme * sc,const char * s,int len)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
putcharacter(scheme * sc,int c)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 */
readstr_upto(scheme * sc,char * delim)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" */
readstrexp(scheme * sc)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 */
is_one_of(char * s,int c)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 */
skipspace(scheme * sc)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 */
token(scheme * sc)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
printslashstring(scheme * sc,char * p,int len)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 */
printatom(scheme * sc,pointer l,int f)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 */
atom2str(scheme * sc,pointer l,int f,char ** pp,int * plen)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 */
mk_closure(scheme * sc,pointer c,pointer e)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. */
mk_continuation(scheme * sc,pointer d)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
list_star(scheme * sc,pointer d)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 */
reverse(scheme * sc,pointer a)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 */
reverse_in_place(scheme * sc,pointer term,pointer list)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 */
append(scheme * sc,pointer a,pointer b)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 */
eqv(pointer a,pointer b)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
hash_fn(const char * key,int table_size)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
new_frame_in_env(scheme * sc,pointer old_env)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
new_slot_spec_in_env(scheme * sc,pointer env,pointer variable,pointer value)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
find_slot_in_env(scheme * sc,pointer env,pointer hdl,int all)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
new_frame_in_env(scheme * sc,pointer old_env)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
new_slot_spec_in_env(scheme * sc,pointer env,pointer variable,pointer value)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
find_slot_in_env(scheme * sc,pointer env,pointer hdl,int all)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
new_slot_in_env(scheme * sc,pointer variable,pointer value)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
set_slot_in_env(scheme * sc,pointer slot,pointer value)2007 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2008 {
2009 cdr(slot) = value;
2010 }
2011
slot_value_in_env(pointer slot)2012 static INLINE pointer slot_value_in_env(pointer slot)
2013 {
2014 return cdr(slot);
2015 }
2016
2017 /* ========== Evaluation Cycle ========== */
2018
2019
_Error_1(scheme * sc,const char * s,pointer a)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
s_save(scheme * sc,enum scheme_opcodes op,pointer args,pointer code)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
_s_return(scheme * sc,pointer a)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
dump_stack_reset(scheme * sc)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
dump_stack_initialize(scheme * sc)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
dump_stack_free(scheme * sc)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
dump_stack_mark(scheme * sc)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
dump_stack_reset(scheme * sc)2149 static INLINE void dump_stack_reset(scheme *sc)
2150 {
2151 sc->dump = sc->NIL;
2152 }
2153
dump_stack_initialize(scheme * sc)2154 static INLINE void dump_stack_initialize(scheme *sc)
2155 {
2156 dump_stack_reset(sc);
2157 }
2158
dump_stack_free(scheme * sc)2159 static void dump_stack_free(scheme *sc)
2160 {
2161 sc->dump = sc->NIL;
2162 }
2163
_s_return(scheme * sc,pointer a)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
s_save(scheme * sc,enum scheme_opcodes op,pointer args,pointer code)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
dump_stack_mark(scheme * sc)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
opexe_0(scheme * sc,enum scheme_opcodes op)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
opexe_1(scheme * sc,enum scheme_opcodes op)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
opexe_2(scheme * sc,enum scheme_opcodes op)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
list_length(scheme * sc,pointer a)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
opexe_3(scheme * sc,enum scheme_opcodes op)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
opexe_4(scheme * sc,enum scheme_opcodes op)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
opexe_5(scheme * sc,enum scheme_opcodes op)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
opexe_6(scheme * sc,enum scheme_opcodes op)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);
is_any(pointer p)3854 static int is_any(pointer p) { return 1;}
is_num_integer(pointer p)3855 static int is_num_integer(pointer p) {
3856 return is_number(p) && ((p)->_object._number.is_fixnum);
3857 }
is_nonneg(pointer p)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
procname(pointer x)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 */
Eval_Cycle(scheme * sc,enum scheme_opcodes op)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
assign_syntax(scheme * sc,char * name)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
assign_proc(scheme * sc,enum scheme_opcodes op,char * name)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
mk_proc(scheme * sc,enum scheme_opcodes op)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! */
syntaxnum(pointer p)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
s_cons(scheme * sc,pointer a,pointer b)4070 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
4071 return cons(sc,a,b);
4072 }
s_immutable_cons(scheme * sc,pointer a,pointer b)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
scheme_init_new()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
scheme_init_new_custom_alloc(func_alloc malloc,func_dealloc free)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
scheme_init(scheme * sc)4159 int scheme_init(scheme *sc) {
4160 return scheme_init_custom_alloc(sc,malloc,free);
4161 }
4162
scheme_init_custom_alloc(scheme * sc,func_alloc malloc,func_dealloc free)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
scheme_set_input_port_file(scheme * sc,FILE * fin)4257 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
4258 sc->inport=port_from_file(sc,fin,port_input);
4259 }
4260
scheme_set_input_port_string(scheme * sc,char * start,char * past_the_end)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
scheme_set_output_port_file(scheme * sc,FILE * fout)4265 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
4266 sc->outport=port_from_file(sc,fout,port_output);
4267 }
4268
scheme_set_output_port_string(scheme * sc,char * start,char * past_the_end)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
scheme_set_external_data(scheme * sc,void * p)4273 void scheme_set_external_data(scheme *sc, void *p) {
4274 sc->ext_data=p;
4275 }
4276
scheme_deinit(scheme * sc)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
scheme_load_file(scheme * sc,FILE * fin)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
scheme_load_string(scheme * sc,const char * cmd)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
scheme_define(scheme * sc,pointer envir,pointer symbol,pointer value)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
scheme_apply0(scheme * sc,const char * procname)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
scheme_call(scheme * sc,pointer func,pointer args)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
main()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 }
MacTS_main(int argc,char ** argv)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
4478