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