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 246272 : static const char *strlwr(char *s) {
93 246272 : const char *p=s;
94 1858434 : while(*s) {
95 1365890 : *s=tolower(*s);
96 1365890 : s++;
97 : }
98 246272 : 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 26552614 : static INLINE int num_is_integer(pointer p) {
196 26552614 : 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 649916 : 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 145116115 : 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 1209996 : INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
216 71125 : INTERFACE INLINE int is_integer(pointer p) {
217 71125 : if (!is_number(p))
218 0 : return 0;
219 71125 : if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
220 71125 : 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 255423 : INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
229 35712 : INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
230 1090711 : INLINE num nvalue(pointer p) { return ((p)->_object._number); }
231 26481021 : 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 55786 : INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); }
238 :
239 391901 : INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
240 141046 : INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; }
241 71967 : INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
242 :
243 44363311 : 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 213270 : INTERFACE pointer pair_car(pointer p) { return car(p); }
247 103054 : 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 23943618 : INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
252 6979384 : 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 9798472 : INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
259 7149187 : INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
260 1562046 : 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 1511732 : INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
266 6748617 : INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
267 2767060 : INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
268 1383530 : INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
269 :
270 128202 : INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
271 : #define cont_dump(p) cdr(p)
272 :
273 32856 : INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
274 28596 : INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
275 28596 : return p->_object._foreign_object._vtable;
276 : }
277 28596 : INTERFACE void *get_foreign_object_data(pointer p) {
278 28596 : return p->_object._foreign_object._data;
279 : }
280 :
281 : /* To do: promise should be forced ONCE only */
282 232 : INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
283 :
284 41978 : 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 62709 : INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
296 : /*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
297 6956458 : 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 617 : 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 1158 : static int is_ascii_name(const char *name, int *pc) {
355 : int i;
356 38214 : for(i=0; i<32; i++) {
357 37056 : if(stricmp(name,charnames[i])==0) {
358 0 : *pc=i;
359 0 : return 1;
360 : }
361 : }
362 1158 : if(stricmp(name,"del")==0) {
363 0 : *pc=127;
364 0 : return 1;
365 : }
366 1158 : 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 59362 : static num num_add(num a, num b) {
433 : num ret;
434 59362 : ret.is_fixnum=a.is_fixnum && b.is_fixnum;
435 59362 : if(ret.is_fixnum) {
436 59362 : ret.value.ivalue= a.value.ivalue+b.value.ivalue;
437 : } else {
438 0 : ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
439 : }
440 59362 : 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 14675 : static num num_sub(num a, num b) {
477 : num ret;
478 14675 : ret.is_fixnum=a.is_fixnum && b.is_fixnum;
479 14675 : if(ret.is_fixnum) {
480 14675 : ret.value.ivalue= a.value.ivalue-b.value.ivalue;
481 : } else {
482 0 : ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
483 : }
484 14675 : 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 340278 : static int num_eq(num a, num b) {
524 : int ret;
525 340278 : int is_fixnum=a.is_fixnum && b.is_fixnum;
526 340278 : if(is_fixnum) {
527 340278 : ret= a.value.ivalue==b.value.ivalue;
528 : } else {
529 0 : ret=num_rvalue(a)==num_rvalue(b);
530 : }
531 340278 : return ret;
532 : }
533 :
534 :
535 2265 : static int num_gt(num a, num b) {
536 : int ret;
537 2265 : int is_fixnum=a.is_fixnum && b.is_fixnum;
538 2265 : if(is_fixnum) {
539 2265 : ret= a.value.ivalue>b.value.ivalue;
540 : } else {
541 0 : ret=num_rvalue(a)>num_rvalue(b);
542 : }
543 2265 : return ret;
544 : }
545 :
546 12350 : static int num_ge(num a, num b) {
547 12350 : return !num_lt(a,b);
548 : }
549 :
550 12399 : static int num_lt(num a, num b) {
551 : int ret;
552 12399 : int is_fixnum=a.is_fixnum && b.is_fixnum;
553 12399 : if(is_fixnum) {
554 12399 : ret= a.value.ivalue<b.value.ivalue;
555 : } else {
556 0 : ret=num_rvalue(a)<num_rvalue(b);
557 : }
558 12399 : 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 205 : _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
605 : {
606 205 : int adj = ADJ;
607 : void *cp;
608 :
609 205 : if (adj < sizeof(struct cell))
610 0 : adj = sizeof(struct cell);
611 :
612 205 : cp = sc->malloc(len * sizeof(struct cell) + adj);
613 205 : if (cp == NULL)
614 0 : return 1;
615 :
616 205 : *alloc = cp;
617 :
618 : /* adjust in TYPE_BITS-bit boundary */
619 205 : if (((uintptr_t) cp) % adj != 0)
620 102 : cp = (void *) (adj * ((uintptr_t) cp / adj + 1));
621 :
622 205 : *cells = cp;
623 205 : return 0;
624 : }
625 :
626 : /* allocate new cell segment */
627 52 : 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 206 : for (k = 0; k < n; k++) {
635 154 : if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
636 0 : return k;
637 154 : i = ++sc->last_cell_seg;
638 154 : 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 154 : sc->cell_seg[i] = newp;
644 308 : 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 154 : sc->fcells += CELL_SEGSIZE;
650 154 : last = newp + CELL_SEGSIZE - 1;
651 770154 : for (p = newp; p <= last; p++) {
652 770000 : typeflag(p) = 0;
653 770000 : cdr(p) = p + 1;
654 770000 : car(p) = sc->NIL;
655 : }
656 : /* insert new cells in address order on free list */
657 154 : if (sc->free_cell == sc->NIL || p < sc->free_cell) {
658 51 : cdr(last) = sc->free_cell;
659 51 : sc->free_cell = newp;
660 : } else {
661 103 : p = sc->free_cell;
662 765105 : while (cdr(p) != sc->NIL && newp > cdr(p))
663 764899 : p = cdr(p);
664 103 : cdr(last) = cdr(p);
665 103 : cdr(p) = newp;
666 : }
667 : }
668 52 : 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 42487120 : _gc_disable(struct scheme *sc, size_t reserve, int lineno)
730 : {
731 42487120 : if (sc->inhibit_gc == 0) {
732 42199748 : reserve_cells(sc, (reserve));
733 42199748 : sc->reserved_cells = (reserve);
734 : #ifndef NDEBUG
735 : (void) lineno;
736 : #else
737 : sc->reserved_lineno = lineno;
738 : #endif
739 287372 : } else if (sc->reserved_cells < (reserve))
740 0 : gc_reservation_failure (sc);
741 42487120 : sc->inhibit_gc += 1;
742 42487120 : }
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 108386696 : static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
776 108386696 : if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
777 108386525 : pointer x = sc->free_cell;
778 108386525 : if (! gc_enabled (sc))
779 107631222 : gc_consume (sc);
780 108386525 : sc->free_cell = cdr(x);
781 108386525 : --sc->fcells;
782 108386525 : 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 42199748 : static pointer reserve_cells(scheme *sc, int n) {
818 42199748 : if(sc->no_memory) {
819 0 : return sc->NIL;
820 : }
821 :
822 : /* Are there enough cells available? */
823 42199748 : if (sc->fcells < n) {
824 : /* If not, try gc'ing some */
825 9016 : gc(sc, sc->NIL, sc->NIL);
826 9016 : 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 9016 : if (sc->fcells < n) {
834 : /* If all fail, report failure */
835 0 : sc->no_memory=1;
836 0 : return sc->NIL;
837 : }
838 : }
839 42199748 : return (sc->T);
840 : }
841 :
842 102 : static pointer get_consecutive_cells(scheme *sc, int n) {
843 : pointer x;
844 :
845 102 : if(sc->no_memory) { return sc->sink; }
846 :
847 : /* Are there any cells available? */
848 102 : x=find_consecutive_cells(sc,n);
849 102 : 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 102 : static int count_consecutive_cells(pointer x, int needed) {
872 102 : int n=1;
873 23766 : while(cdr(x)==x+1) {
874 23664 : x=cdr(x);
875 23664 : n++;
876 23664 : if(n>needed) return n;
877 : }
878 0 : return n;
879 : }
880 :
881 102 : static pointer find_consecutive_cells(scheme *sc, int n) {
882 : pointer *pp;
883 : int cnt;
884 :
885 102 : pp=&sc->free_cell;
886 204 : while(*pp!=sc->NIL) {
887 102 : cnt=count_consecutive_cells(*pp,n);
888 102 : if(cnt>=n) {
889 102 : pointer x=*pp;
890 102 : *pp=cdr(*pp+n-1);
891 102 : sc->fcells -= n;
892 102 : 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 83738908 : free_cell(scheme *sc, pointer a)
903 : {
904 83738908 : cdr(a) = sc->free_cell;
905 83738908 : sc->free_cell = a;
906 83738908 : sc->fcells += 1;
907 83738908 : }
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 83335964 : free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
913 : {
914 83335964 : *r_car = car(a);
915 83335964 : *r_cdr = cdr(a);
916 83335964 : free_cell(sc, a);
917 83335964 : }
918 :
919 : /* To retain recent allocs before interpreter knows about them -
920 : Tehom */
921 :
922 402945 : static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
923 : {
924 402945 : pointer holder = get_cell_x(sc, recent, extra);
925 402945 : typeflag(holder) = T_PAIR | T_IMMUTABLE;
926 402945 : car(holder) = recent;
927 402945 : cdr(holder) = car(sc->sink);
928 402945 : car(sc->sink) = holder;
929 402945 : }
930 :
931 32955336 : static INLINE void ok_to_freely_gc(scheme *sc)
932 : {
933 32955336 : pointer a = car(sc->sink), next;
934 32955336 : car(sc->sink) = sc->NIL;
935 66313616 : while (a != sc->NIL)
936 : {
937 402944 : next = cdr(a);
938 402944 : free_cell(sc, a);
939 402944 : a = next;
940 : }
941 32955336 : }
942 :
943 107983751 : static pointer get_cell(scheme *sc, pointer a, pointer b)
944 : {
945 107983751 : 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 107983751 : typeflag(cell) = T_PAIR;
950 107983751 : car(cell) = a;
951 107983751 : cdr(cell) = b;
952 107983751 : if (gc_enabled (sc))
953 352529 : push_recent_alloc(sc, cell, sc->NIL);
954 107983751 : return cell;
955 : }
956 :
957 102 : static pointer get_vector_object(scheme *sc, int len, pointer init)
958 : {
959 102 : pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
960 102 : if(sc->no_memory) { return sc->sink; }
961 : /* Record it as a vector so that gc understands it. */
962 102 : typeflag(cells) = (T_VECTOR | T_ATOM);
963 102 : ivalue_unchecked(cells)=len;
964 102 : set_num_integer(cells);
965 102 : fill_vector(cells,init);
966 102 : if (gc_enabled (sc))
967 102 : push_recent_alloc(sc, cells, sc->NIL);
968 102 : 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 107664883 : pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
999 107664883 : pointer x = get_cell(sc,a, b);
1000 :
1001 107664883 : typeflag(x) = T_PAIR;
1002 107664883 : if(immutable) {
1003 6877228 : setimmutable(x);
1004 : }
1005 107664883 : car(x) = a;
1006 107664883 : cdr(x) = b;
1007 107664883 : 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 51 : static pointer oblist_initial_value(scheme *sc)
1017 : {
1018 51 : return mk_vector(sc, 461); /* probably should be bigger */
1019 : }
1020 :
1021 : /* returns the new symbol */
1022 42156 : 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 42156 : gc_disable(sc, gc_reservations (oblist_add_by_name));
1029 42156 : x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
1030 42156 : typeflag(x) = T_SYMBOL;
1031 42156 : setimmutable(car(x));
1032 :
1033 42156 : location = hash_fn(name, ivalue_unchecked(sc->oblist));
1034 42156 : set_vector_elem(sc->oblist, location,
1035 : immutable_cons(sc, x, vector_elem(sc->oblist, location)));
1036 42156 : gc_enable(sc);
1037 42156 : return x;
1038 : }
1039 :
1040 263198 : static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
1041 : {
1042 : int location;
1043 : pointer x;
1044 : char *s;
1045 :
1046 263198 : location = hash_fn(name, ivalue_unchecked(sc->oblist));
1047 375203 : for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
1048 333863 : s = symname(car(x));
1049 : /* case-insensitive, per R5RS section 2. */
1050 333863 : if(stricmp(name, s) == 0) {
1051 221858 : return car(x);
1052 : }
1053 : }
1054 41340 : 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 4421 : static pointer mk_port(scheme *sc, port *p) {
1112 4421 : pointer x = get_cell(sc, sc->NIL, sc->NIL);
1113 :
1114 4421 : typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
1115 4421 : x->_object._port=p;
1116 4421 : return (x);
1117 : }
1118 :
1119 2397 : pointer mk_foreign_func(scheme *sc, foreign_func f) {
1120 2397 : pointer x = get_cell(sc, sc->NIL, sc->NIL);
1121 :
1122 2397 : typeflag(x) = (T_FOREIGN | T_ATOM);
1123 2397 : x->_object._ff=f;
1124 2397 : return (x);
1125 : }
1126 :
1127 4260 : pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
1128 4260 : pointer x = get_cell(sc, sc->NIL, sc->NIL);
1129 :
1130 4260 : typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
1131 4260 : x->_object._foreign_object._vtable=vtable;
1132 4260 : x->_object._foreign_object._data = data;
1133 4260 : return (x);
1134 : }
1135 :
1136 101040 : INTERFACE pointer mk_character(scheme *sc, int c) {
1137 101040 : pointer x = get_cell(sc,sc->NIL, sc->NIL);
1138 :
1139 101040 : typeflag(x) = (T_CHARACTER | T_ATOM);
1140 101040 : ivalue_unchecked(x)= c;
1141 101040 : set_num_integer(x);
1142 101040 : 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 51 : initialize_small_integers(scheme *sc)
1155 : {
1156 : int i;
1157 51 : if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc,
1158 : &sc->integer_cells))
1159 0 : return 1;
1160 :
1161 8466 : for (i = 0; i < MAX_SMALL_INTEGER; i++) {
1162 8415 : pointer x = &sc->integer_cells[i];
1163 8415 : typeflag(x) = T_NUMBER | T_ATOM | MARK;
1164 8415 : ivalue_unchecked(x) = i;
1165 8415 : set_num_integer(x);
1166 : }
1167 :
1168 51 : return 0;
1169 : }
1170 :
1171 : static INLINE pointer
1172 21009825 : mk_small_integer(scheme *sc, long n)
1173 : {
1174 : #define mk_small_integer_allocates 0
1175 21009825 : assert(0 <= n && n < MAX_SMALL_INTEGER);
1176 21009825 : 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 190707 : INTERFACE pointer mk_integer(scheme *sc, long n) {
1187 : pointer x;
1188 :
1189 : #if USE_SMALL_INTEGERS
1190 190707 : if (0 <= n && n < MAX_SMALL_INTEGER)
1191 175609 : return mk_small_integer(sc, n);
1192 : #endif
1193 :
1194 15098 : x = get_cell(sc,sc->NIL, sc->NIL);
1195 15098 : typeflag(x) = (T_NUMBER | T_ATOM);
1196 15098 : ivalue_unchecked(x)= n;
1197 15098 : set_num_integer(x);
1198 15098 : return (x);
1199 : }
1200 :
1201 :
1202 :
1203 255 : INTERFACE pointer mk_real(scheme *sc, double n) {
1204 255 : pointer x = get_cell(sc,sc->NIL, sc->NIL);
1205 :
1206 255 : typeflag(x) = (T_NUMBER | T_ATOM);
1207 255 : rvalue_unchecked(x)= n;
1208 255 : set_num_real(x);
1209 255 : return (x);
1210 : }
1211 :
1212 44356 : static pointer mk_number(scheme *sc, num n) {
1213 44356 : if(n.is_fixnum) {
1214 44356 : 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 95095 : static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
1222 : char *q;
1223 :
1224 95095 : q=(char*)sc->malloc(len_str+1);
1225 95095 : if(q==0) {
1226 0 : sc->no_memory=1;
1227 0 : return sc->strbuff;
1228 : }
1229 95095 : if(str!=0) {
1230 66734 : memcpy (q, str, len_str);
1231 66734 : q[len_str]=0;
1232 : } else {
1233 28361 : memset(q, fill, len_str);
1234 28361 : q[len_str]=0;
1235 : }
1236 95095 : return (q);
1237 : }
1238 :
1239 : /* get new string */
1240 49040 : INTERFACE pointer mk_string(scheme *sc, const char *str) {
1241 49040 : return mk_counted_string(sc,str,strlen(str));
1242 : }
1243 :
1244 65504 : INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
1245 65504 : pointer x = get_cell(sc, sc->NIL, sc->NIL);
1246 65504 : typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1247 65504 : strvalue(x) = store_string(sc,len,str,0);
1248 65504 : strlength(x) = len;
1249 65504 : return (x);
1250 : }
1251 :
1252 28311 : INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
1253 28311 : pointer x = get_cell(sc, sc->NIL, sc->NIL);
1254 28311 : typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
1255 28311 : strvalue(x) = store_string(sc,len,0,fill);
1256 28311 : strlength(x) = len;
1257 28311 : return (x);
1258 : }
1259 :
1260 102 : INTERFACE static pointer mk_vector(scheme *sc, int len)
1261 102 : { return get_vector_object(sc,len,sc->NIL); }
1262 :
1263 102 : INTERFACE static void fill_vector(pointer vec, pointer obj) {
1264 : int i;
1265 102 : int n = ivalue(vec)/2+ivalue(vec)%2;
1266 23664 : for(i=0; i < n; i++) {
1267 23562 : typeflag(vec+1+i) = T_PAIR;
1268 23562 : setimmutable(vec+1+i);
1269 23562 : car(vec+1+i)=obj;
1270 23562 : cdr(vec+1+i)=obj;
1271 : }
1272 102 : }
1273 :
1274 6942565 : INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1275 6942565 : int n=ielem/2;
1276 6942565 : if(ielem%2==0) {
1277 2912629 : return car(vec+1+n);
1278 : } else {
1279 4029936 : return cdr(vec+1+n);
1280 : }
1281 : }
1282 :
1283 67590 : INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1284 67590 : int n=ielem/2;
1285 67590 : if(ielem%2==0) {
1286 32506 : return car(vec+1+n)=a;
1287 : } else {
1288 35084 : return cdr(vec+1+n)=a;
1289 : }
1290 : }
1291 :
1292 : /* get new symbol */
1293 255907 : 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 255907 : x = oblist_find_by_name(sc, name);
1299 255907 : if (x != sc->NIL) {
1300 218238 : return (x);
1301 : } else {
1302 37669 : x = oblist_add_by_name(sc, name);
1303 37669 : return (x);
1304 : }
1305 : }
1306 :
1307 3671 : INTERFACE pointer gensym(scheme *sc) {
1308 : pointer x;
1309 : char name[40];
1310 :
1311 14582 : for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1312 7291 : snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1313 :
1314 : /* first check oblist */
1315 7291 : x = oblist_find_by_name(sc, name);
1316 :
1317 7291 : if (x != sc->NIL) {
1318 3620 : continue;
1319 : } else {
1320 3671 : x = oblist_add_by_name(sc, name);
1321 3671 : 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 252169 : static pointer mk_atom(scheme *sc, char *q) {
1345 : char c, *p;
1346 252169 : int has_dec_point=0;
1347 252169 : int has_fp_exp = 0;
1348 :
1349 : #if USE_COLON_HOOK
1350 252169 : if((p=strstr(q,"::"))!=0) {
1351 1260 : *p=0;
1352 1260 : 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 250909 : p = q;
1362 250909 : c = *p++;
1363 250909 : if ((c == '+') || (c == '-')) {
1364 3369 : c = *p++;
1365 3369 : if (c == '.') {
1366 0 : has_dec_point=1;
1367 0 : c = *p++;
1368 : }
1369 3573 : if (!isdigit(c)) {
1370 3165 : return (mk_symbol(sc, strlwr(q)));
1371 : }
1372 247540 : } 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 247540 : } else if (!isdigit(c)) {
1379 241847 : return (mk_symbol(sc, strlwr(q)));
1380 : }
1381 :
1382 8096 : for ( ; (c = *p) != 0; ++p) {
1383 2199 : if (!isdigit(c)) {
1384 255 : if(c=='.') {
1385 255 : if(!has_dec_point) {
1386 255 : has_dec_point=1;
1387 255 : 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 5897 : if(has_dec_point) {
1404 255 : return mk_real(sc,atof(q));
1405 : }
1406 5642 : return (mk_integer(sc, atol(q)));
1407 : }
1408 :
1409 : /* make constant */
1410 4549 : static pointer mk_sharp_const(scheme *sc, char *name) {
1411 : long x;
1412 : char tmp[STRBUFFSIZE];
1413 :
1414 4549 : if (!strcmp(name, "t"))
1415 1183 : return (sc->T);
1416 3366 : else if (!strcmp(name, "f"))
1417 1795 : return (sc->F);
1418 1571 : else if (*name == 'o') {/* #o (octal) */
1419 256 : snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1420 256 : sscanf(tmp, "%lo", (long unsigned *)&x);
1421 256 : return (mk_integer(sc, x));
1422 1315 : } else if (*name == 'd') { /* #d (decimal) */
1423 0 : sscanf(name+1, "%ld", (long int *)&x);
1424 0 : return (mk_integer(sc, x));
1425 1315 : } 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 1313 : } else if (*name == 'b') { /* #b (binary) */
1430 0 : x = binary_decode(name+1);
1431 0 : return (mk_integer(sc, x));
1432 1313 : } else if (*name == '\\') { /* #\w (character) */
1433 1313 : int c=0;
1434 1313 : if(stricmp(name+1,"space")==0) {
1435 1 : c=' ';
1436 1312 : } else if(stricmp(name+1,"newline")==0) {
1437 154 : c='\n';
1438 1158 : } else if(stricmp(name+1,"return")==0) {
1439 0 : c='\r';
1440 1158 : } else if(stricmp(name+1,"tab")==0) {
1441 0 : c='\t';
1442 1158 : } 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 1158 : } else if(is_ascii_name(name+1,&c)) {
1451 : /* nothing */
1452 : #endif
1453 1158 : } else if(name[2]==0) {
1454 1158 : c=name[1];
1455 : } else {
1456 0 : return sc->NIL;
1457 : }
1458 1313 : 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 4382949 : static void mark(pointer a) {
1471 : pointer t, q, p;
1472 :
1473 4382949 : t = (pointer) 0;
1474 4382949 : p = a;
1475 115827141 : E2: setmark(p);
1476 115827141 : if(is_vector(p)) {
1477 : int i;
1478 18374 : int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1479 4262768 : for(i=0; i < n; i++) {
1480 : /* Vector cells will be treated like ordinary cells */
1481 4244394 : mark(p+1+i);
1482 : }
1483 : }
1484 115827141 : if (is_atom(p))
1485 12085748 : goto E6;
1486 : /* E4: down car */
1487 103741393 : q = car(p);
1488 103741393 : if (q && !is_mark(q)) {
1489 55775383 : setatom(p); /* a note that we have moved car */
1490 55775383 : car(p) = t;
1491 55775383 : t = p;
1492 55775383 : p = q;
1493 55775383 : goto E2;
1494 : }
1495 103741393 : E5: q = cdr(p); /* down cdr */
1496 103741393 : if (q && !is_mark(q)) {
1497 55668809 : cdr(p) = t;
1498 55668809 : t = p;
1499 55668809 : p = q;
1500 55668809 : goto E2;
1501 : }
1502 : E6: /* up. Undo the link switching from steps E4 and E5. */
1503 115827141 : if (!t)
1504 8765898 : return;
1505 111444192 : q = t;
1506 111444192 : if (is_atom(q)) {
1507 55775383 : clratom(q);
1508 55775383 : t = car(q);
1509 55775383 : car(q) = p;
1510 55775383 : p = q;
1511 55775383 : goto E5;
1512 : } else {
1513 55668809 : t = cdr(q);
1514 55668809 : cdr(q) = p;
1515 55668809 : p = q;
1516 55668809 : goto E6;
1517 : }
1518 : }
1519 :
1520 : /* garbage collection. parameter a, b is marked. */
1521 9237 : static void gc(scheme *sc, pointer a, pointer b) {
1522 : pointer p;
1523 : int i;
1524 :
1525 9237 : assert (gc_enabled (sc));
1526 :
1527 9237 : if(sc->gc_verbose) {
1528 0 : putstr(sc, "gc...");
1529 : }
1530 :
1531 : /* mark system globals */
1532 9237 : mark(sc->oblist);
1533 9237 : mark(sc->global_env);
1534 :
1535 : /* mark current registers */
1536 9237 : mark(sc->args);
1537 9237 : mark(sc->envir);
1538 9237 : mark(sc->code);
1539 9237 : dump_stack_mark(sc);
1540 9237 : mark(sc->value);
1541 9237 : mark(sc->inport);
1542 9237 : mark(sc->save_inport);
1543 9237 : mark(sc->outport);
1544 9237 : mark(sc->loadport);
1545 :
1546 : /* Mark recent objects the interpreter doesn't know about yet. */
1547 9237 : mark(car(sc->sink));
1548 : /* Mark any older stuff above nested C calls */
1549 9237 : mark(sc->c_nest);
1550 :
1551 : /* mark variables a, b */
1552 9237 : mark(a);
1553 9237 : mark(b);
1554 :
1555 : /* garbage collect */
1556 9237 : clrmark(sc->NIL);
1557 9237 : sc->fcells = 0;
1558 9237 : 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 37333 : for (i = sc->last_cell_seg; i >= 0; i--) {
1565 28096 : p = sc->cell_seg[i] + CELL_SEGSIZE;
1566 140536192 : while (--p >= sc->cell_seg[i]) {
1567 140480000 : if (is_mark(p)) {
1568 115737716 : clrmark(p);
1569 : } else {
1570 : /* reclaim cell */
1571 24742284 : if (typeflag(p) & T_FINALIZE) {
1572 98491 : finalize_cell(sc, p);
1573 : }
1574 24742284 : ++sc->fcells;
1575 24742284 : typeflag(p) = 0;
1576 24742284 : car(p) = sc->NIL;
1577 24742284 : cdr(p) = sc->free_cell;
1578 24742284 : sc->free_cell = p;
1579 : }
1580 : }
1581 : }
1582 :
1583 9237 : 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 9237 : }
1589 :
1590 98491 : static void finalize_cell(scheme *sc, pointer a) {
1591 98491 : if(is_string(a)) {
1592 92567 : sc->free(strvalue(a));
1593 5924 : } else if(is_port(a)) {
1594 1664 : if(a->_object._port->kind&port_file
1595 446 : && a->_object._port->rep.stdio.closeit) {
1596 92 : port_close(sc,a,port_input|port_output);
1597 1572 : } else if (a->_object._port->kind & port_srfi6) {
1598 385 : sc->free(a->_object._port->rep.string.start);
1599 : }
1600 1664 : sc->free(a->_object._port);
1601 4260 : } else if(is_foreign_object(a)) {
1602 4260 : a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
1603 : }
1604 98491 : }
1605 :
1606 : /* ========== Routines for Reading ========== */
1607 :
1608 49 : static int file_push(scheme *sc, const char *fname) {
1609 49 : FILE *fin = NULL;
1610 :
1611 49 : if (sc->file_i == MAXFIL-1)
1612 0 : return 0;
1613 49 : fin=fopen(fname,"r");
1614 49 : if(fin!=0) {
1615 49 : sc->file_i++;
1616 49 : sc->load_stack[sc->file_i].kind=port_file|port_input;
1617 49 : sc->load_stack[sc->file_i].rep.stdio.file=fin;
1618 49 : sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1619 49 : sc->nesting_stack[sc->file_i]=0;
1620 49 : sc->loadport->_object._port=sc->load_stack+sc->file_i;
1621 :
1622 : #if SHOW_ERROR_LINE
1623 49 : sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1624 49 : if(fname)
1625 49 : sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1626 : #endif
1627 : }
1628 49 : return fin!=0;
1629 : }
1630 :
1631 49 : static void file_pop(scheme *sc) {
1632 49 : if(sc->file_i != 0) {
1633 49 : sc->nesting=sc->nesting_stack[sc->file_i];
1634 49 : port_close(sc,sc->loadport,port_input);
1635 49 : sc->file_i--;
1636 49 : sc->loadport->_object._port=sc->load_stack+sc->file_i;
1637 : }
1638 49 : }
1639 :
1640 38992 : static int file_interactive(scheme *sc) {
1641 112684 : return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1642 38992 : && sc->inport->_object._port->kind&port_file;
1643 : }
1644 :
1645 989 : static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1646 : FILE *f;
1647 : char *rw;
1648 : port *pt;
1649 989 : if(prop==(port_input|port_output)) {
1650 92 : rw="a+";
1651 897 : } else if(prop==port_output) {
1652 13 : rw="w";
1653 : } else {
1654 884 : rw="r";
1655 : }
1656 989 : f=fopen(fn,rw);
1657 989 : if(f==0) {
1658 64 : return 0;
1659 : }
1660 925 : pt=port_rep_from_file(sc,f,prop);
1661 925 : pt->rep.stdio.closeit=1;
1662 :
1663 : #if SHOW_ERROR_LINE
1664 925 : if(fn)
1665 925 : pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1666 :
1667 925 : pt->rep.stdio.curr_line = 0;
1668 : #endif
1669 925 : return pt;
1670 : }
1671 :
1672 989 : static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1673 : port *pt;
1674 989 : pt=port_rep_from_filename(sc,fn,prop);
1675 989 : if(pt==0) {
1676 64 : return sc->NIL;
1677 : }
1678 925 : return mk_port(sc,pt);
1679 : }
1680 :
1681 1283 : static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1682 : {
1683 : port *pt;
1684 :
1685 1283 : pt = (port *)sc->malloc(sizeof *pt);
1686 1283 : if (pt == NULL) {
1687 0 : return NULL;
1688 : }
1689 1283 : pt->kind = port_file | prop;
1690 1283 : pt->rep.stdio.file = f;
1691 1283 : pt->rep.stdio.closeit = 0;
1692 1283 : return pt;
1693 : }
1694 :
1695 358 : static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1696 : port *pt;
1697 358 : pt=port_rep_from_file(sc,f,prop);
1698 358 : if(pt==0) {
1699 0 : return sc->NIL;
1700 : }
1701 358 : 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 385 : static port *port_rep_from_scratch(scheme *sc) {
1729 : port *pt;
1730 : char *start;
1731 385 : pt=(port*)sc->malloc(sizeof(port));
1732 385 : if(pt==0) {
1733 0 : return 0;
1734 : }
1735 385 : start=sc->malloc(BLOCK_SIZE);
1736 385 : if(start==0) {
1737 0 : return 0;
1738 : }
1739 385 : memset(start,' ',BLOCK_SIZE-1);
1740 385 : start[BLOCK_SIZE-1]='\0';
1741 385 : pt->kind=port_string|port_output|port_srfi6;
1742 385 : pt->rep.string.start=start;
1743 385 : pt->rep.string.curr=start;
1744 385 : pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1745 385 : return pt;
1746 : }
1747 :
1748 385 : static pointer port_from_scratch(scheme *sc) {
1749 : port *pt;
1750 385 : pt=port_rep_from_scratch(sc);
1751 385 : if(pt==0) {
1752 0 : return sc->NIL;
1753 : }
1754 385 : return mk_port(sc,pt);
1755 : }
1756 :
1757 974 : static void port_close(scheme *sc, pointer p, int flag) {
1758 974 : port *pt=p->_object._port;
1759 974 : pt->kind&=~flag;
1760 974 : if((pt->kind & (port_input|port_output))==0) {
1761 974 : if(pt->kind&port_file) {
1762 :
1763 : #if SHOW_ERROR_LINE
1764 : /* Cleanup is here so (close-*-port) functions could work too */
1765 974 : pt->rep.stdio.curr_line = 0;
1766 :
1767 974 : if(pt->rep.stdio.filename)
1768 974 : sc->free(pt->rep.stdio.filename);
1769 : #endif
1770 :
1771 974 : fclose(pt->rep.stdio.file);
1772 : }
1773 974 : pt->kind=port_free;
1774 : }
1775 974 : }
1776 :
1777 : /* get new character from input file */
1778 4599330 : static int inchar(scheme *sc) {
1779 : int c;
1780 : port *pt;
1781 :
1782 4599330 : pt = sc->inport->_object._port;
1783 4599330 : if(pt->kind & port_saw_EOF)
1784 0 : { return EOF; }
1785 4599330 : c = basic_inchar(pt);
1786 4599330 : if(c == EOF && sc->inport == sc->loadport) {
1787 : /* Instead, set port_saw_EOF */
1788 2801 : pt->kind |= port_saw_EOF;
1789 :
1790 : /* file_pop(sc); */
1791 2801 : return EOF;
1792 : /* NOTREACHED */
1793 : }
1794 4596529 : return c;
1795 : }
1796 :
1797 4599330 : static int basic_inchar(port *pt) {
1798 4599330 : if(pt->kind & port_file) {
1799 4386179 : return fgetc(pt->rep.stdio.file);
1800 : } else {
1801 423855 : if(*pt->rep.string.curr == 0 ||
1802 210704 : pt->rep.string.curr == pt->rep.string.past_the_end) {
1803 2447 : return EOF;
1804 : } else {
1805 210704 : return *pt->rep.string.curr++;
1806 : }
1807 : }
1808 : }
1809 :
1810 : /* back character to input buffer */
1811 1257483 : static void backchar(scheme *sc, int c) {
1812 : port *pt;
1813 2514966 : if(c==EOF) return;
1814 1255036 : pt=sc->inport->_object._port;
1815 1255036 : if(pt->kind&port_file) {
1816 1190067 : ungetc(c,pt->rep.stdio.file);
1817 : } else {
1818 64969 : if(pt->rep.string.curr!=pt->rep.string.start) {
1819 64969 : --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 2061 : INTERFACE void putstr(scheme *sc, const char *s) {
1845 2061 : port *pt=sc->outport->_object._port;
1846 2061 : if(pt->kind&port_file) {
1847 195 : fputs(s,pt->rep.stdio.file);
1848 : } else {
1849 3732 : for(;*s;s++) {
1850 1866 : if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1851 1866 : *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 2061 : }
1858 :
1859 38326 : static void putchars(scheme *sc, const char *s, int len) {
1860 38326 : port *pt=sc->outport->_object._port;
1861 38326 : if(pt->kind&port_file) {
1862 1772 : fwrite(s,1,len,pt->rep.stdio.file);
1863 : } else {
1864 82052 : for(;len;len--) {
1865 45498 : if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1866 45384 : *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 38326 : }
1873 :
1874 15008 : INTERFACE void putcharacter(scheme *sc, int c) {
1875 15008 : port *pt=sc->outport->_object._port;
1876 15008 : if(pt->kind&port_file) {
1877 0 : fputc(c,pt->rep.stdio.file);
1878 : } else {
1879 15008 : if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1880 15005 : *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 15008 : }
1886 :
1887 : /* read characters up to delimiter, but cater to character constants */
1888 255395 : static char *readstr_upto(scheme *sc, char *delim) {
1889 255395 : char *p = sc->strbuff;
1890 :
1891 1894991 : while ((p - sc->strbuff < sc->strbuff_size) &&
1892 1639596 : !is_one_of(delim, (*p++ = inchar(sc))));
1893 :
1894 255395 : if(p == sc->strbuff+2 && p[-2] == '\\') {
1895 46 : *p=0;
1896 : } else {
1897 255349 : backchar(sc,p[-1]);
1898 255349 : *--p = '\0';
1899 : }
1900 255395 : return sc->strbuff;
1901 : }
1902 :
1903 : /* read string expression "xxx...xxx" */
1904 13432 : static pointer readstrexp(scheme *sc) {
1905 13432 : char *p = sc->strbuff;
1906 : int c;
1907 13432 : int c1=0;
1908 13432 : enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1909 :
1910 : for (;;) {
1911 239693 : c=inchar(sc);
1912 239693 : if(c == EOF) {
1913 0 : return sc->F;
1914 : }
1915 239693 : 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 239693 : switch(state) {
1923 : case st_ok:
1924 239440 : switch(c) {
1925 : case '\\':
1926 253 : state=st_bsl;
1927 253 : break;
1928 : case '"':
1929 13432 : *p=0;
1930 13432 : return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1931 : default:
1932 225755 : *p++=c;
1933 225755 : break;
1934 : }
1935 226008 : break;
1936 : case st_bsl:
1937 253 : 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 198 : *p++='\n';
1956 198 : state=st_ok;
1957 198 : break;
1958 : case 't':
1959 0 : *p++='\t';
1960 0 : state=st_ok;
1961 0 : break;
1962 : case 'r':
1963 51 : *p++='\r';
1964 51 : state=st_ok;
1965 51 : 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 253 : 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 226261 : }
2022 : }
2023 :
2024 : /* check c is in chars */
2025 1648182 : static INLINE int is_one_of(char *s, int c) {
2026 1648182 : if(c==EOF) return 1;
2027 18843219 : while (*s)
2028 15810836 : if (*s++ == c)
2029 263981 : return (1);
2030 1384201 : return (0);
2031 : }
2032 :
2033 : /* skip white characters */
2034 615338 : static INLINE int skipspace(scheme *sc) {
2035 615338 : int c = 0, curr_line = 0;
2036 :
2037 : do {
2038 1254462 : c=inchar(sc);
2039 : #if SHOW_ERROR_LINE
2040 1254462 : if(c=='\n')
2041 22803 : curr_line++;
2042 : #endif
2043 1254462 : } while (isspace(c));
2044 :
2045 : /* record it */
2046 : #if SHOW_ERROR_LINE
2047 615338 : if (sc->load_stack[sc->file_i].kind & port_file)
2048 581630 : sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
2049 : #endif
2050 :
2051 615338 : if(c!=EOF) {
2052 614984 : backchar(sc,c);
2053 614984 : return 1;
2054 : }
2055 : else
2056 354 : { return EOF; }
2057 : }
2058 :
2059 : /* get token */
2060 615338 : static int token(scheme *sc) {
2061 : int c;
2062 615338 : c = skipspace(sc);
2063 615338 : if(c == EOF) { return (TOK_EOF); }
2064 614984 : switch (c=inchar(sc)) {
2065 : case EOF:
2066 0 : return (TOK_EOF);
2067 : case '(':
2068 156654 : return (TOK_LPAREN);
2069 : case ')':
2070 156654 : return (TOK_RPAREN);
2071 : case '.':
2072 4039 : c=inchar(sc);
2073 4039 : if(is_one_of(" \n\t",c)) {
2074 4039 : return (TOK_DOT);
2075 : } else {
2076 0 : backchar(sc,c);
2077 0 : backchar(sc,'.');
2078 0 : return TOK_ATOM;
2079 : }
2080 : case '\'':
2081 3760 : return (TOK_QUOTE);
2082 : case ';':
2083 16390 : while ((c=inchar(sc)) != '\n' && c!=EOF)
2084 : ;
2085 :
2086 : #if SHOW_ERROR_LINE
2087 16390 : if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2088 16390 : sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2089 : #endif
2090 :
2091 16390 : if(c == EOF)
2092 0 : { return (TOK_EOF); }
2093 : else
2094 16390 : { return (token(sc));}
2095 : case '"':
2096 13432 : return (TOK_DQUOTE);
2097 : case BACKQUOTE:
2098 2687 : return (TOK_BQUOTE);
2099 : case ',':
2100 5924 : if ((c=inchar(sc)) == '@') {
2101 2053 : return (TOK_ATMARK);
2102 : } else {
2103 3871 : backchar(sc,c);
2104 3871 : return (TOK_COMMA);
2105 : }
2106 : case '#':
2107 4596 : c=inchar(sc);
2108 4596 : if (c == '(') {
2109 0 : return (TOK_VEC);
2110 4596 : } else if(c == '!') {
2111 49 : while ((c=inchar(sc)) != '\n' && c!=EOF)
2112 : ;
2113 :
2114 : #if SHOW_ERROR_LINE
2115 49 : if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
2116 49 : sc->load_stack[sc->file_i].rep.stdio.curr_line++;
2117 : #endif
2118 :
2119 49 : if(c == EOF)
2120 0 : { return (TOK_EOF); }
2121 : else
2122 49 : { return (token(sc));}
2123 : } else {
2124 4547 : backchar(sc,c);
2125 4547 : if(is_one_of(" tfodxb\\",c)) {
2126 4547 : return TOK_SHARP_CONST;
2127 : } else {
2128 0 : return (TOK_SHARP);
2129 : }
2130 : }
2131 : default:
2132 250848 : backchar(sc,c);
2133 250848 : return (TOK_ATOM);
2134 : }
2135 : }
2136 :
2137 : /* ========== Routines for Printing ========== */
2138 : #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
2139 :
2140 469 : static void printslashstring(scheme *sc, char *p, int len) {
2141 : int i;
2142 469 : unsigned char *s=(unsigned char*)p;
2143 469 : putcharacter(sc,'"');
2144 14539 : for ( i=0; i<len; i++) {
2145 14070 : 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 14070 : putcharacter(sc,*s);
2181 : }
2182 14070 : s++;
2183 : }
2184 469 : putcharacter(sc,'"');
2185 469 : }
2186 :
2187 :
2188 : /* print atoms */
2189 38326 : static void printatom(scheme *sc, pointer l, int f) {
2190 : char *p;
2191 : int len;
2192 38326 : atom2str(sc,l,f,&p,&len);
2193 38326 : putchars(sc,p,len);
2194 38326 : }
2195 :
2196 :
2197 : /* Uses internal buffer unless string pointer is already available */
2198 38419 : static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
2199 : char *p;
2200 :
2201 38419 : if (l == sc->NIL) {
2202 0 : p = "()";
2203 38419 : } else if (l == sc->T) {
2204 0 : p = "#t";
2205 38419 : } else if (l == sc->F) {
2206 0 : p = "#f";
2207 38419 : } else if (l == sc->EOF_OBJ) {
2208 0 : p = "#<EOF>";
2209 38419 : } else if (is_port(l)) {
2210 0 : p = "#<PORT>";
2211 38419 : } 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 38285 : } else if (is_string(l)) {
2247 2169 : if (!f) {
2248 1700 : *pp = strvalue(l);
2249 1700 : *plen = strlength(l);
2250 1700 : return;
2251 : } else { /* Hack, uses the fact that printing is needed */
2252 469 : *pp=sc->strbuff;
2253 469 : *plen=0;
2254 469 : printslashstring(sc, strvalue(l), strlength(l));
2255 469 : return;
2256 : }
2257 36116 : } 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 1078 : } else if (is_symbol(l)) {
2297 1078 : 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 36250 : *pp=p;
2319 36250 : *plen=strlen(p);
2320 : }
2321 : /* ========== Routines for Evaluation Cycle ========== */
2322 :
2323 : /* make closure. c is code. e is environment */
2324 89113 : static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2325 89113 : pointer x = get_cell(sc, c, e);
2326 :
2327 89113 : typeflag(x) = T_CLOSURE;
2328 89113 : car(x) = c;
2329 89113 : cdr(x) = e;
2330 89113 : return (x);
2331 : }
2332 :
2333 : /* make continuation. */
2334 3012 : static pointer mk_continuation(scheme *sc, pointer d) {
2335 3012 : pointer x = get_cell(sc, sc->NIL, d);
2336 :
2337 3012 : typeflag(x) = T_CONTINUATION;
2338 3012 : cont_dump(x) = d;
2339 3012 : return (x);
2340 : }
2341 :
2342 152284 : static pointer list_star(scheme *sc, pointer d) {
2343 : pointer p, q;
2344 152284 : if(cdr(d)==sc->NIL) {
2345 152284 : 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 1446 : static pointer reverse(scheme *sc, pointer term, pointer list) {
2361 : /* a must be checked by gc */
2362 1446 : pointer a = list, p = term;
2363 :
2364 13682 : for ( ; is_pair(a); a = cdr(a)) {
2365 12236 : p = cons(sc, car(a), p);
2366 : }
2367 1446 : return (p);
2368 : }
2369 :
2370 : /* reverse list --- in-place */
2371 6995379 : static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2372 6995379 : pointer p = list, result = term, q;
2373 :
2374 31078583 : while (p != sc->NIL) {
2375 17087825 : q = cdr(p);
2376 17087825 : cdr(p) = result;
2377 17087825 : result = p;
2378 17087825 : p = q;
2379 : }
2380 6995379 : return (result);
2381 : }
2382 :
2383 : /* append list -- produce new list (in reverse order) */
2384 23897 : static pointer revappend(scheme *sc, pointer a, pointer b) {
2385 23897 : pointer result = a;
2386 23897 : pointer p = b;
2387 :
2388 63644 : while (is_pair(p)) {
2389 15850 : result = cons(sc, car(p), result);
2390 15850 : p = cdr(p);
2391 : }
2392 :
2393 23897 : if (p == sc->NIL) {
2394 23897 : return result;
2395 : }
2396 :
2397 0 : return sc->F; /* signal an error */
2398 : }
2399 :
2400 : /* equivalence of atoms */
2401 144063 : int eqv(pointer a, pointer b) {
2402 144063 : if (is_string(a)) {
2403 1576 : if (is_string(b))
2404 0 : return (strvalue(a) == strvalue(b));
2405 : else
2406 1576 : return (0);
2407 142487 : } else if (is_number(a)) {
2408 7910 : if (is_number(b)) {
2409 167 : if (num_is_integer(a) == num_is_integer(b))
2410 167 : return num_eq(nvalue(a),nvalue(b));
2411 : }
2412 7743 : return (0);
2413 134577 : } 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 134395 : } else if (is_port(a)) {
2419 0 : if (is_port(b))
2420 0 : return a==b;
2421 : else
2422 0 : return (0);
2423 134395 : } 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 134395 : 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 6942565 : static int hash_fn(const char *key, int table_size)
2443 : {
2444 6942565 : unsigned int hashed = 0;
2445 : const char *c;
2446 6942565 : int bits_per_int = sizeof(unsigned int)*8;
2447 :
2448 39737702 : for (c = key; *c; c++) {
2449 : /* letters have about 5 bits in them */
2450 32795137 : hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2451 32795137 : hashed ^= *c;
2452 : }
2453 6942565 : 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 1557296 : 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 1557296 : if (old_env == sc->NIL) {
2473 51 : new_frame = mk_vector(sc, 461);
2474 : } else {
2475 1557245 : new_frame = sc->NIL;
2476 : }
2477 :
2478 1557296 : gc_disable(sc, 1);
2479 1557296 : sc->envir = immutable_cons(sc, new_frame, old_env);
2480 1557296 : gc_enable(sc);
2481 1557296 : setenvironment(sc->envir);
2482 1557296 : }
2483 :
2484 2569228 : 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 2569228 : gc_disable(sc, gc_reservations (new_slot_spec_in_env));
2490 2569228 : slot = immutable_cons(sc, variable, value);
2491 :
2492 2569228 : if (is_vector(car(env))) {
2493 25434 : int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2494 :
2495 25434 : set_vector_elem(car(env), location,
2496 : immutable_cons(sc, slot, vector_elem(car(env), location)));
2497 : } else {
2498 2543794 : car(env) = immutable_cons(sc, slot, car(env));
2499 : }
2500 2569228 : gc_enable(sc);
2501 2569228 : }
2502 :
2503 12636412 : static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2504 : {
2505 : pointer x,y;
2506 : int location;
2507 :
2508 26648816 : for (x = env; x != sc->NIL; x = cdr(x)) {
2509 26647235 : if (is_vector(car(x))) {
2510 6611777 : location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2511 6611777 : y = vector_elem(car(x), location);
2512 : } else {
2513 20035458 : y = car(x);
2514 : }
2515 67741182 : for ( ; y != sc->NIL; y = cdr(y)) {
2516 53669890 : if (caar(y) == hdl) {
2517 12575943 : break;
2518 : }
2519 : }
2520 26647235 : if (y != sc->NIL) {
2521 12575943 : break;
2522 : }
2523 14071292 : if(!all) {
2524 58888 : return sc->NIL;
2525 : }
2526 : }
2527 12577524 : if (x != sc->NIL) {
2528 12575943 : return car(y);
2529 : }
2530 1581 : 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 2565760 : 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 2565760 : new_slot_spec_in_env(sc, sc->envir, variable, value);
2575 2565760 : }
2576 :
2577 6611 : static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2578 : {
2579 : (void)sc;
2580 6611 : cdr(slot) = value;
2581 6611 : }
2582 :
2583 12569332 : static INLINE pointer slot_value_in_env(pointer slot)
2584 : {
2585 12569332 : 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 2804 : static INLINE void dump_stack_reset(scheme *sc)
2686 : {
2687 2804 : sc->dump = sc->NIL;
2688 2804 : }
2689 :
2690 51 : static INLINE void dump_stack_initialize(scheme *sc)
2691 : {
2692 51 : dump_stack_reset(sc);
2693 51 : }
2694 :
2695 50 : static void dump_stack_free(scheme *sc)
2696 : {
2697 50 : sc->dump = sc->NIL;
2698 50 : }
2699 :
2700 20833991 : static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
2701 20833991 : pointer dump = sc->dump;
2702 : pointer op;
2703 20833991 : sc->value = (a);
2704 20833991 : if (enable_gc)
2705 251744 : gc_enable(sc);
2706 20833991 : if (dump == sc->NIL)
2707 0 : return sc->NIL;
2708 20833991 : free_cons(sc, dump, &op, &dump);
2709 20833991 : sc->op = ivalue(op);
2710 : #ifndef USE_SMALL_INTEGERS
2711 : free_cell(sc, op);
2712 : #endif
2713 20833991 : free_cons(sc, dump, &sc->args, &dump);
2714 20833991 : free_cons(sc, dump, &sc->envir, &dump);
2715 20833991 : free_cons(sc, dump, &sc->code, &sc->dump);
2716 20833991 : return sc->T;
2717 : }
2718 :
2719 20834216 : 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 20834216 : gc_disable(sc, gc_reservations (s_save));
2723 20834216 : dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2724 20834216 : dump = cons(sc, (args), dump);
2725 20834216 : sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump);
2726 20834216 : gc_enable(sc);
2727 20834216 : }
2728 :
2729 9237 : static INLINE void dump_stack_mark(scheme *sc)
2730 : {
2731 9237 : mark(sc->dump);
2732 9237 : }
2733 :
2734 : #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
2735 :
2736 23151210 : static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2737 : pointer x, y;
2738 :
2739 23151210 : switch (op) {
2740 : CASE(OP_LOAD): /* load */
2741 49 : 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 49 : if (!file_push(sc,strvalue(car(sc->args)))) {
2746 0 : Error_1(sc,"unable to open", car(sc->args));
2747 : }
2748 : else
2749 : {
2750 49 : sc->args = mk_integer(sc,sc->file_i);
2751 49 : 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 22273 : if(sc->loadport->_object._port->kind & port_saw_EOF)
2757 : {
2758 2801 : if(sc->file_i == 0)
2759 : {
2760 2752 : sc->args=sc->NIL;
2761 2752 : sc->nesting = sc->nesting_stack[0];
2762 2752 : s_goto(sc,OP_QUIT);
2763 : }
2764 : else
2765 : {
2766 49 : file_pop(sc);
2767 49 : s_return(sc,sc->value);
2768 : }
2769 : /* NOTREACHED */
2770 : }
2771 :
2772 : /* If interactive, be nice to user. */
2773 19472 : 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 19472 : sc->nesting=0;
2783 19472 : sc->save_inport=sc->inport;
2784 19472 : sc->inport = sc->loadport;
2785 19472 : s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2786 19472 : s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2787 19472 : s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2788 19472 : s_thread_to(sc,OP_READ_INTERNAL);
2789 :
2790 : CASE(OP_T1LVL): /* top level */
2791 19472 : sc->code = sc->value;
2792 19472 : sc->inport=sc->save_inport;
2793 19472 : s_thread_to(sc,OP_EVAL);
2794 :
2795 : CASE(OP_READ_INTERNAL): /* internal read */
2796 19472 : sc->tok = token(sc);
2797 19472 : if(sc->tok==TOK_EOF)
2798 354 : { s_return(sc,sc->EOF_OBJ); }
2799 19118 : s_goto(sc,OP_RDSEXPR);
2800 :
2801 : CASE(OP_GENSYM):
2802 3671 : 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 19471 : if(sc->tracing) {
2809 0 : putstr(sc,"\nGives: ");
2810 : }
2811 19471 : 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 19471 : s_return(sc,sc->value);
2817 : }
2818 :
2819 : CASE(OP_EVAL): /* main part of evaluation */
2820 : #if USE_TRACING
2821 23059006 : 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 23059006 : if (is_symbol(sc->code)) { /* symbol */
2832 12496799 : x=find_slot_in_env(sc,sc->envir,sc->code,1);
2833 12496799 : if (x != sc->NIL) {
2834 12496799 : s_return(sc,slot_value_in_env(x));
2835 : } else {
2836 0 : Error_1(sc,"eval: unbound variable:", sc->code);
2837 : }
2838 10562207 : } else if (is_pair(sc->code)) {
2839 9798472 : if (is_syntax(x = car(sc->code))) { /* SYNTAX */
2840 3139510 : sc->code = cdr(sc->code);
2841 3139510 : s_goto(sc,syntaxnum(x));
2842 : } else {/* first, eval top element and eval arguments */
2843 6658962 : s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2844 : /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2845 6658962 : sc->code = car(sc->code);
2846 6658962 : s_thread_to(sc,OP_EVAL);
2847 : }
2848 : } else {
2849 763735 : s_return(sc,sc->code);
2850 : }
2851 :
2852 : CASE(OP_E0ARGS): /* eval arguments */
2853 6658962 : if (is_macro(sc->value)) { /* macro expansion */
2854 16908 : gc_disable(sc, 1 + gc_reservations (s_save));
2855 16908 : s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2856 16908 : sc->args = cons(sc,sc->code, sc->NIL);
2857 16908 : gc_enable(sc);
2858 16908 : sc->code = sc->value;
2859 16908 : s_thread_to(sc,OP_APPLY);
2860 : } else {
2861 6642054 : sc->code = cdr(sc->code);
2862 6642054 : s_thread_to(sc,OP_E1ARGS);
2863 : }
2864 :
2865 : CASE(OP_E1ARGS): /* eval arguments */
2866 16309099 : gc_disable(sc, 1);
2867 16309099 : sc->args = cons(sc, sc->value, sc->args);
2868 16309099 : gc_enable(sc);
2869 16309099 : if (is_pair(sc->code)) { /* continue */
2870 9667050 : s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2871 9667050 : sc->code = car(sc->code);
2872 9667050 : sc->args = sc->NIL;
2873 9667050 : s_thread_to(sc,OP_EVAL);
2874 : } else { /* end */
2875 6642049 : sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2876 6642049 : sc->code = car(sc->args);
2877 6642049 : sc->args = cdr(sc->args);
2878 6642049 : 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 6886795 : 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 6886795 : if (is_proc(sc->code)) {
2903 5452746 : s_goto(sc,procnum(sc->code)); /* PROCEDURE */
2904 1434049 : } else if (is_foreign(sc->code))
2905 : {
2906 : /* Keep nested calls from GC'ing the arglist */
2907 50314 : push_recent_alloc(sc,sc->args,sc->NIL);
2908 50314 : x=sc->code->_object._ff(sc,sc->args);
2909 50313 : s_return(sc,x);
2910 1383735 : } else if (is_closure(sc->code) || is_macro(sc->code)
2911 216 : || is_promise(sc->code)) { /* CLOSURE */
2912 : /* Should not accept promise */
2913 : /* make environment */
2914 1383530 : new_frame_in_env(sc, closure_env(sc->code));
2915 4688975 : for (x = car(closure_code(sc->code)), y = sc->args;
2916 1921915 : is_pair(x); x = cdr(x), y = cdr(y)) {
2917 1921915 : if (y == sc->NIL) {
2918 0 : Error_1(sc, "not enough arguments, missing:", x);
2919 : } else {
2920 1921915 : new_slot_in_env(sc, car(x), car(y));
2921 : }
2922 : }
2923 1383530 : if (x == sc->NIL) {
2924 : /*--
2925 : * if (y != sc->NIL) {
2926 : * Error_0(sc,"too many arguments");
2927 : * }
2928 : */
2929 341926 : } else if (is_symbol(x))
2930 341926 : new_slot_in_env(sc, x, y);
2931 : else {
2932 0 : Error_1(sc,"syntax error in closure: not a symbol:", x);
2933 : }
2934 1383530 : sc->code = cdr(closure_code(sc->code));
2935 1383530 : sc->args = sc->NIL;
2936 1383530 : s_thread_to(sc,OP_BEGIN);
2937 205 : } else if (is_continuation(sc->code)) { /* CONTINUATION */
2938 205 : sc->dump = cont_dump(sc->code);
2939 205 : 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 16908 : sc->code = sc->value;
2946 16908 : 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 74061 : pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2954 74061 : if(f==sc->NIL) {
2955 1530 : sc->value = sc->code;
2956 : /* Fallthru */
2957 : } else {
2958 72531 : gc_disable(sc, 1 + gc_reservations (s_save));
2959 72531 : s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2960 72531 : sc->args=cons(sc,sc->code,sc->NIL);
2961 72531 : gc_enable(sc);
2962 72531 : sc->code=slot_value_in_env(f);
2963 72531 : 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 74061 : gc_disable(sc, 1);
2975 74061 : 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 1066547 : s_return(sc,car(sc->code));
2993 :
2994 : CASE(OP_DEF0): /* define */
2995 54768 : if(is_immutable(car(sc->code)))
2996 0 : Error_1(sc,"define: unable to alter immutable", car(sc->code));
2997 :
2998 54768 : if (is_pair(car(sc->code))) {
2999 52160 : x = caar(sc->code);
3000 52160 : gc_disable(sc, 2);
3001 52160 : sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3002 52160 : gc_enable(sc);
3003 : } else {
3004 2608 : x = car(sc->code);
3005 2608 : sc->code = cadr(sc->code);
3006 : }
3007 54768 : if (!is_symbol(x)) {
3008 0 : Error_0(sc,"variable is not a symbol");
3009 : }
3010 54768 : s_save(sc,OP_DEF1, sc->NIL, x);
3011 54768 : s_thread_to(sc,OP_EVAL);
3012 :
3013 : CASE(OP_DEF1): /* define */
3014 54768 : x=find_slot_in_env(sc,sc->envir,sc->code,0);
3015 54768 : if (x != sc->NIL) {
3016 215 : set_slot_in_env(sc, x, sc->value);
3017 : } else {
3018 54553 : new_slot_in_env(sc, sc->code, sc->value);
3019 : }
3020 54768 : s_return(sc,sc->code);
3021 :
3022 :
3023 : CASE(OP_DEFP): /* defined? */
3024 51 : x=sc->envir;
3025 51 : if(cdr(sc->args)!=sc->NIL) {
3026 0 : x=cadr(sc->args);
3027 : }
3028 51 : s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
3029 :
3030 : CASE(OP_SET0): /* set! */
3031 6396 : if(is_immutable(car(sc->code)))
3032 0 : Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
3033 6396 : s_save(sc,OP_SET1, sc->NIL, car(sc->code));
3034 6396 : sc->code = cadr(sc->code);
3035 6396 : s_thread_to(sc,OP_EVAL);
3036 :
3037 : CASE(OP_SET1): /* set! */
3038 6396 : y=find_slot_in_env(sc,sc->envir,sc->code,1);
3039 6396 : if (y != sc->NIL) {
3040 6396 : set_slot_in_env(sc, y, sc->value);
3041 6396 : 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 2247585 : if (!is_pair(sc->code)) {
3049 663 : s_return(sc,sc->code);
3050 : }
3051 2246922 : if (cdr(sc->code) != sc->NIL) {
3052 103814 : s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
3053 : }
3054 2246922 : sc->code = car(sc->code);
3055 2246922 : s_thread_to(sc,OP_EVAL);
3056 :
3057 : CASE(OP_IF0): /* if */
3058 715910 : s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
3059 715910 : sc->code = car(sc->code);
3060 715910 : s_thread_to(sc,OP_EVAL);
3061 :
3062 : CASE(OP_IF1): /* if */
3063 715908 : if (is_true(sc->value))
3064 203694 : sc->code = car(sc->code);
3065 : else
3066 512214 : sc->code = cadr(sc->code); /* (if #f 1) ==> () because
3067 : * car(sc->NIL) = sc->NIL */
3068 715908 : s_thread_to(sc,OP_EVAL);
3069 :
3070 : CASE(OP_LET0): /* let */
3071 159668 : sc->args = sc->NIL;
3072 159668 : sc->value = sc->code;
3073 159668 : sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
3074 159668 : s_thread_to(sc,OP_LET1);
3075 :
3076 : CASE(OP_LET1): /* let (calculate parameters) */
3077 342479 : gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
3078 342479 : sc->args = cons(sc, sc->value, sc->args);
3079 342479 : if (is_pair(sc->code)) { /* continue */
3080 183019 : 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 183019 : s_save(sc,OP_LET1, sc->args, cdr(sc->code));
3086 183019 : gc_enable(sc);
3087 183019 : sc->code = cadar(sc->code);
3088 183019 : sc->args = sc->NIL;
3089 183019 : s_thread_to(sc,OP_EVAL);
3090 : } else { /* end */
3091 159460 : gc_enable(sc);
3092 159460 : sc->args = reverse_in_place(sc, sc->NIL, sc->args);
3093 159460 : sc->code = car(sc->args);
3094 159460 : sc->args = cdr(sc->args);
3095 159460 : s_thread_to(sc,OP_LET2);
3096 : }
3097 :
3098 : CASE(OP_LET2): /* let */
3099 159460 : new_frame_in_env(sc, sc->envir);
3100 501731 : for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
3101 182811 : y != sc->NIL; x = cdr(x), y = cdr(y)) {
3102 182811 : new_slot_in_env(sc, caar(x), car(y));
3103 : }
3104 159460 : if (is_symbol(car(sc->code))) { /* named let */
3105 33202 : for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
3106 18288 : if (!is_pair(x))
3107 0 : Error_1(sc, "Bad syntax of binding in let :", x);
3108 18288 : if (!is_list(sc, car(x)))
3109 0 : Error_1(sc, "Bad syntax of binding in let :", car(x));
3110 18288 : gc_disable(sc, 1);
3111 18288 : sc->args = cons(sc, caar(x), sc->args);
3112 18288 : gc_enable(sc);
3113 : }
3114 14914 : gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
3115 14914 : x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
3116 14914 : new_slot_in_env(sc, car(sc->code), x);
3117 14914 : gc_enable(sc);
3118 14914 : sc->code = cddr(sc->code);
3119 14914 : sc->args = sc->NIL;
3120 : } else {
3121 144546 : sc->code = cdr(sc->code);
3122 144546 : sc->args = sc->NIL;
3123 : }
3124 159460 : s_thread_to(sc,OP_BEGIN);
3125 :
3126 : CASE(OP_LET0AST): /* let* */
3127 14255 : 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 14255 : 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 14255 : s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
3136 14255 : sc->code = cadaar(sc->code);
3137 14255 : s_thread_to(sc,OP_EVAL);
3138 :
3139 : CASE(OP_LET1AST): /* let* (make new frame) */
3140 14255 : new_frame_in_env(sc, sc->envir);
3141 14255 : s_thread_to(sc,OP_LET2AST);
3142 :
3143 : CASE(OP_LET2AST): /* let* (calculate parameters) */
3144 43266 : new_slot_in_env(sc, caar(sc->code), sc->value);
3145 43266 : sc->code = cdr(sc->code);
3146 43266 : if (is_pair(sc->code)) { /* continue */
3147 29011 : s_save(sc,OP_LET2AST, sc->args, sc->code);
3148 29011 : sc->code = cadar(sc->code);
3149 29011 : sc->args = sc->NIL;
3150 29011 : s_thread_to(sc,OP_EVAL);
3151 : } else { /* end */
3152 14255 : sc->code = sc->args;
3153 14255 : sc->args = sc->NIL;
3154 14255 : 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 3928668 : static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
3164 : pointer x, y;
3165 :
3166 3928668 : 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 581578 : if (!is_pair(sc->code)) {
3204 0 : Error_0(sc,"syntax error in cond");
3205 : }
3206 581578 : s_save(sc,OP_COND1, sc->NIL, sc->code);
3207 581578 : sc->code = caar(sc->code);
3208 581578 : s_goto(sc,OP_EVAL);
3209 :
3210 : CASE(OP_COND1): /* cond */
3211 1579105 : if (is_true(sc->value)) {
3212 581578 : if ((sc->code = cdar(sc->code)) == sc->NIL) {
3213 0 : s_return(sc,sc->value);
3214 : }
3215 581578 : 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 581578 : s_goto(sc,OP_BEGIN);
3226 : } else {
3227 997527 : if ((sc->code = cdr(sc->code)) == sc->NIL) {
3228 0 : s_return(sc,sc->NIL);
3229 : } else {
3230 997527 : s_save(sc,OP_COND1, sc->NIL, sc->code);
3231 997527 : sc->code = caar(sc->code);
3232 997527 : s_goto(sc,OP_EVAL);
3233 : }
3234 : }
3235 :
3236 : CASE(OP_DELAY): /* delay */
3237 138 : gc_disable(sc, 2);
3238 138 : x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3239 138 : typeflag(x)=T_PROMISE;
3240 138 : s_return_enable_gc(sc,x);
3241 :
3242 : CASE(OP_AND0): /* and */
3243 312539 : if (sc->code == sc->NIL) {
3244 0 : s_return(sc,sc->T);
3245 : }
3246 312539 : s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3247 312539 : sc->code = car(sc->code);
3248 312539 : s_goto(sc,OP_EVAL);
3249 :
3250 : CASE(OP_AND1): /* and */
3251 731170 : if (is_false(sc->value)) {
3252 249712 : s_return(sc,sc->value);
3253 481458 : } else if (sc->code == sc->NIL) {
3254 62827 : s_return(sc,sc->value);
3255 : } else {
3256 418631 : s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
3257 418631 : sc->code = car(sc->code);
3258 418631 : s_goto(sc,OP_EVAL);
3259 : }
3260 :
3261 : CASE(OP_OR0): /* or */
3262 147827 : if (sc->code == sc->NIL) {
3263 0 : s_return(sc,sc->F);
3264 : }
3265 147827 : s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3266 147827 : sc->code = car(sc->code);
3267 147827 : s_goto(sc,OP_EVAL);
3268 :
3269 : CASE(OP_OR1): /* or */
3270 415978 : if (is_true(sc->value)) {
3271 9409 : s_return(sc,sc->value);
3272 406569 : } else if (sc->code == sc->NIL) {
3273 138418 : s_return(sc,sc->value);
3274 : } else {
3275 268151 : s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3276 268151 : sc->code = car(sc->code);
3277 268151 : 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 867 : if (is_pair(car(sc->code))) {
3294 765 : x = caar(sc->code);
3295 765 : gc_disable(sc, 2);
3296 765 : sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3297 765 : gc_enable(sc);
3298 : } else {
3299 102 : x = car(sc->code);
3300 102 : sc->code = cadr(sc->code);
3301 : }
3302 867 : if (!is_symbol(x)) {
3303 0 : Error_0(sc,"variable is not a symbol");
3304 : }
3305 867 : s_save(sc,OP_MACRO1, sc->NIL, x);
3306 867 : s_goto(sc,OP_EVAL);
3307 :
3308 : CASE(OP_MACRO1): /* macro */
3309 867 : typeflag(sc->value) = T_MACRO;
3310 867 : x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3311 867 : if (x != sc->NIL) {
3312 0 : set_slot_in_env(sc, x, sc->value);
3313 : } else {
3314 867 : new_slot_in_env(sc, sc->code, sc->value);
3315 : }
3316 867 : 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 152284 : sc->code = car(sc->args);
3359 152284 : sc->args = list_star(sc,cdr(sc->args));
3360 : /*sc->args = cadr(sc->args);*/
3361 152284 : s_goto(sc,OP_APPLY);
3362 :
3363 : CASE(OP_PEVAL): /* eval */
3364 3303 : if(cdr(sc->args)!=sc->NIL) {
3365 3303 : sc->envir=cadr(sc->args);
3366 : }
3367 3303 : sc->code = car(sc->args);
3368 3303 : s_goto(sc,OP_EVAL);
3369 :
3370 : CASE(OP_CONTINUATION): /* call-with-current-continuation */
3371 3012 : sc->code = car(sc->args);
3372 3012 : gc_disable(sc, 2);
3373 3012 : sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3374 3012 : gc_enable(sc);
3375 3012 : 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 2216433 : 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 2216433 : 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 29681 : v=num_zero;
3547 89043 : for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3548 59362 : v=num_add(v,nvalue(car(x)));
3549 : }
3550 29681 : gc_disable(sc, 1);
3551 29681 : 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 14675 : if(cdr(sc->args)==sc->NIL) {
3563 0 : x=sc->args;
3564 0 : v=num_zero;
3565 : } else {
3566 14675 : x = cdr(sc->args);
3567 14675 : v = nvalue(car(sc->args));
3568 : }
3569 29350 : for (; x != sc->NIL; x = cdr(x)) {
3570 14675 : v=num_sub(v,nvalue(car(x)));
3571 : }
3572 14675 : gc_disable(sc, 1);
3573 14675 : 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 1401868 : s_return(sc,caar(sc->args));
3633 :
3634 : CASE(OP_CDR): /* cdr */
3635 486849 : s_return(sc,cdar(sc->args));
3636 :
3637 : CASE(OP_CONS): /* cons */
3638 161970 : cdr(sc->args) = cadr(sc->args);
3639 161970 : 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 28510 : c=(char)ivalue(car(sc->args));
3660 28510 : gc_disable(sc, 1);
3661 28510 : 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 149 : gc_disable(sc, gc_reservations (mk_symbol));
3689 149 : s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
3690 :
3691 : CASE(OP_STR2ATOM): /* string->atom */ {
3692 63 : char *s=strvalue(car(sc->args));
3693 63 : long pf = 0;
3694 63 : 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 63 : pf = ivalue_unchecked(cadr(sc->args));
3698 63 : if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3699 : /* base is OK */
3700 : }
3701 : else {
3702 0 : pf = -1;
3703 : }
3704 : }
3705 63 : if (pf < 0) {
3706 0 : Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3707 63 : } else if(*s=='#') /* no use of base! */ {
3708 2 : s_return(sc, mk_sharp_const(sc, s+1));
3709 : } else {
3710 61 : if (pf == 0 || pf == 10) {
3711 61 : 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 209 : int fill=' ';
3761 : int len;
3762 :
3763 209 : len=ivalue(car(sc->args));
3764 :
3765 209 : if(cdr(sc->args)!=sc->NIL) {
3766 2 : fill=charvalue(cadr(sc->args));
3767 : }
3768 209 : gc_disable(sc, 1);
3769 209 : s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
3770 : }
3771 :
3772 : CASE(OP_STRLEN): /* string-length */
3773 33039 : gc_disable(sc, 1);
3774 33039 : 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 29600 : str=strvalue(car(sc->args));
3781 :
3782 29600 : index=ivalue(cadr(sc->args));
3783 :
3784 29600 : if(index>=strlength(car(sc->args))) {
3785 0 : Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3786 : }
3787 :
3788 29600 : gc_disable(sc, 1);
3789 29600 : 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 1545 : if(is_immutable(car(sc->args))) {
3799 0 : Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3800 : }
3801 1545 : str=strvalue(car(sc->args));
3802 :
3803 1545 : index=ivalue(cadr(sc->args));
3804 1545 : if(index>=strlength(car(sc->args))) {
3805 0 : Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3806 : }
3807 :
3808 1545 : c=charvalue(caddr(sc->args));
3809 :
3810 1545 : str[index]=(char)c;
3811 1545 : 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 8294 : int len = 0;
3817 : pointer newstr;
3818 : char *pos;
3819 :
3820 : /* compute needed length for new string */
3821 30974 : for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3822 22680 : len += strlength(car(x));
3823 : }
3824 8294 : gc_disable(sc, 1);
3825 8294 : newstr = mk_empty_string(sc, len, ' ');
3826 : /* store the contents of the argument strings into the new string */
3827 39268 : for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3828 22680 : pos += strlength(car(x)), x = cdr(x)) {
3829 22680 : memcpy(pos, strvalue(car(x)), strlength(car(x)));
3830 : }
3831 8294 : 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 19808 : str=strvalue(car(sc->args));
3841 :
3842 19808 : index0=ivalue(cadr(sc->args));
3843 :
3844 19808 : if(index0>strlength(car(sc->args))) {
3845 0 : Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3846 : }
3847 :
3848 19808 : if(cddr(sc->args)!=sc->NIL) {
3849 19804 : index1=ivalue(caddr(sc->args));
3850 19804 : 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 19808 : len=index1-index0;
3858 19808 : gc_disable(sc, 1);
3859 19808 : x=mk_empty_string(sc,len,' ');
3860 19808 : memcpy(strvalue(x),str+index0,len);
3861 19808 : strvalue(x)[len]=0;
3862 :
3863 19808 : 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 20231 : static int is_list(scheme *sc, pointer a)
3939 20231 : { 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 5584770 : int list_length(scheme *sc, pointer a) {
3948 5584770 : int i=0;
3949 : pointer slow, fast;
3950 :
3951 5584770 : slow = fast = a;
3952 : while (1)
3953 : {
3954 7348558 : if (fast == sc->NIL)
3955 1735303 : return i;
3956 5613255 : if (!is_pair(fast))
3957 0 : return -2 - i;
3958 5613255 : fast = cdr(fast);
3959 5613255 : ++i;
3960 5613255 : if (fast == sc->NIL)
3961 3849467 : return i;
3962 1763788 : if (!is_pair(fast))
3963 0 : return -2 - i;
3964 1763788 : ++i;
3965 1763788 : fast = cdr(fast);
3966 :
3967 : /* Safe because we would have already returned if `fast'
3968 : encountered a non-pair. */
3969 1763788 : slow = cdr(slow);
3970 1763788 : 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 1763788 : }
3978 : }
3979 :
3980 2863615 : static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
3981 : pointer x;
3982 : num v;
3983 2863615 : int (*comp_func)(num,num)=0;
3984 :
3985 2863615 : switch (op) {
3986 : CASE(OP_NOT): /* not */
3987 324199 : 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 85743 : 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 354775 : switch(op) {
4000 340111 : case OP_NUMEQ: comp_func=num_eq; break;
4001 49 : case OP_LESS: comp_func=num_lt; break;
4002 2265 : case OP_GRE: comp_func=num_gt; break;
4003 0 : case OP_LEQ: comp_func=num_le; break;
4004 12350 : case OP_GEQ: comp_func=num_ge; break;
4005 0 : default: assert (! "reached");
4006 : }
4007 354775 : x=sc->args;
4008 354775 : v=nvalue(car(x));
4009 354775 : x=cdr(x);
4010 :
4011 646890 : for (; x != sc->NIL; x = cdr(x)) {
4012 354775 : if(!comp_func(v,nvalue(car(x)))) {
4013 62660 : s_retbool(0);
4014 : }
4015 292115 : v=nvalue(car(x));
4016 : }
4017 292115 : s_retbool(1);
4018 : CASE(OP_SYMBOLP): /* symbol? */
4019 102 : s_retbool(is_symbol(car(sc->args)));
4020 : CASE(OP_NUMBERP): /* number? */
4021 128250 : s_retbool(is_number(car(sc->args)));
4022 : CASE(OP_STRINGP): /* string? */
4023 215806 : 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 617 : 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 127997 : 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 660134 : 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 33487 : s_retbool(is_vector(car(sc->args)));
4065 : CASE(OP_EQ): /* eq? */
4066 753365 : s_retbool(car(sc->args) == cadr(sc->args));
4067 : CASE(OP_EQV): /* eqv? */
4068 144063 : 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 69397 : static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
4077 : pointer x, y;
4078 :
4079 69397 : 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 37158 : if(is_pair(cdr(sc->args))) {
4099 35681 : if(cadr(sc->args)!=sc->outport) {
4100 35681 : x=cons(sc,sc->outport,sc->NIL);
4101 35681 : s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
4102 35681 : sc->outport=cadr(sc->args);
4103 : }
4104 : }
4105 37158 : sc->args = car(sc->args);
4106 37158 : if(op==OP_WRITE) {
4107 349 : sc->print_flag = 1;
4108 : } else {
4109 36809 : sc->print_flag = 0;
4110 : }
4111 37158 : s_goto(sc,OP_P0LIST);
4112 :
4113 : CASE(OP_NEWLINE): /* newline */
4114 195 : 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 195 : putstr(sc, "\n");
4122 195 : 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 1446 : 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 23897 : x = sc->NIL;
4159 23897 : y = sc->args;
4160 23897 : 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 71691 : while (cdr(y) != sc->NIL) {
4167 23897 : x = revappend(sc, x, car(y));
4168 23897 : y = cdr(y);
4169 23897 : if (x == sc->F) {
4170 0 : Error_0(sc, "non-list argument to append");
4171 : }
4172 : }
4173 :
4174 23897 : 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 2752 : if(is_pair(sc->args)) {
4188 0 : sc->retcode=ivalue(car(sc->args));
4189 : }
4190 2752 : 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 51 : { int was = sc->gc_verbose;
4198 :
4199 51 : sc->gc_verbose = (car(sc->args) != sc->F);
4200 51 : 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 989 : int prop=0;
4223 : pointer p;
4224 989 : switch(op) {
4225 884 : case OP_OPEN_INFILE: prop=port_input; break;
4226 13 : case OP_OPEN_OUTFILE: prop=port_output; break;
4227 92 : case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
4228 0 : default: assert (! "reached");
4229 : }
4230 989 : p=port_from_filename(sc,strvalue(car(sc->args)),prop);
4231 989 : if(p==sc->NIL) {
4232 64 : s_return(sc,sc->F);
4233 : }
4234 925 : 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 385 : if(car(sc->args)==sc->NIL) {
4259 385 : p=port_from_scratch(sc);
4260 385 : 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 385 : s_return(sc,p);
4272 : }
4273 : CASE(OP_GET_OUTSTRING): /* get-output-string */ {
4274 : port *p;
4275 :
4276 385 : if ((p=car(sc->args)->_object._port)->kind&port_string) {
4277 : off_t size;
4278 : char *str;
4279 :
4280 385 : size=p->rep.string.curr-p->rep.string.start+1;
4281 385 : str=sc->malloc(size);
4282 385 : if(str != NULL) {
4283 : pointer s;
4284 :
4285 385 : memcpy(str,p->rep.string.start,size-1);
4286 385 : str[size-1]='\0';
4287 385 : s=mk_string(sc,str);
4288 385 : sc->free(str);
4289 385 : 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 820 : port_close(sc,car(sc->args),port_input);
4298 820 : 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 1273 : s_return(sc,sc->envir);
4309 :
4310 : }
4311 : return sc->T;
4312 : }
4313 :
4314 652446 : static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
4315 : pointer x;
4316 :
4317 652446 : 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 652446 : 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 35693 : sc->outport=car(sc->args);
4379 35693 : s_return(sc,sc->value);
4380 :
4381 : CASE(OP_RDSEXPR):
4382 437852 : 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 156654 : sc->tok = token(sc);
4391 156654 : if (sc->tok == TOK_RPAREN) {
4392 1595 : s_return(sc,sc->NIL);
4393 155059 : } else if (sc->tok == TOK_DOT) {
4394 0 : Error_0(sc,"syntax error: illegal dot expression");
4395 : } else {
4396 155059 : sc->nesting_stack[sc->file_i]++;
4397 155059 : s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
4398 155059 : s_thread_to(sc,OP_RDSEXPR);
4399 : }
4400 : case TOK_QUOTE:
4401 3760 : s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
4402 3760 : sc->tok = token(sc);
4403 3760 : s_thread_to(sc,OP_RDSEXPR);
4404 : case TOK_BQUOTE:
4405 2687 : sc->tok = token(sc);
4406 2687 : 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 2687 : s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
4412 : }
4413 2687 : s_thread_to(sc,OP_RDSEXPR);
4414 : case TOK_COMMA:
4415 3871 : s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
4416 3871 : sc->tok = token(sc);
4417 3871 : s_thread_to(sc,OP_RDSEXPR);
4418 : case TOK_ATMARK:
4419 2053 : s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
4420 2053 : sc->tok = token(sc);
4421 2053 : s_thread_to(sc,OP_RDSEXPR);
4422 : case TOK_ATOM:
4423 250848 : s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
4424 : case TOK_DQUOTE:
4425 13432 : x=readstrexp(sc);
4426 13432 : if(x==sc->F) {
4427 0 : Error_0(sc,"Error reading string");
4428 : }
4429 13432 : setimmutable(x);
4430 13432 : 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 4547 : if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
4442 0 : Error_0(sc,"undefined sharp expression");
4443 : } else {
4444 4547 : 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 402324 : gc_disable(sc, 1);
4453 402324 : sc->args = cons(sc, sc->value, sc->args);
4454 402324 : gc_enable(sc);
4455 402324 : sc->tok = token(sc);
4456 402324 : if (sc->tok == TOK_EOF)
4457 0 : { s_return(sc,sc->EOF_OBJ); }
4458 402324 : else if (sc->tok == TOK_RPAREN) {
4459 151020 : int c = inchar(sc);
4460 151020 : if (c != '\n')
4461 92847 : backchar(sc,c);
4462 : #if SHOW_ERROR_LINE
4463 58173 : else if (sc->load_stack[sc->file_i].kind & port_file)
4464 58173 : sc->load_stack[sc->file_i].rep.stdio.curr_line++;
4465 : #endif
4466 151020 : sc->nesting_stack[sc->file_i]--;
4467 151020 : s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
4468 251304 : } else if (sc->tok == TOK_DOT) {
4469 4039 : s_save(sc,OP_RDDOT, sc->args, sc->NIL);
4470 4039 : sc->tok = token(sc);
4471 4039 : s_thread_to(sc,OP_RDSEXPR);
4472 : } else {
4473 247265 : s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
4474 247265 : s_thread_to(sc,OP_RDSEXPR);
4475 : }
4476 : }
4477 :
4478 : CASE(OP_RDDOT):
4479 4039 : if (token(sc) != TOK_RPAREN) {
4480 0 : Error_0(sc,"syntax error: illegal dot expression");
4481 : } else {
4482 4039 : sc->nesting_stack[sc->file_i]--;
4483 4039 : s_return(sc,reverse_in_place(sc, sc->value, sc->args));
4484 : }
4485 :
4486 : CASE(OP_RDQUOTE):
4487 3760 : gc_disable(sc, 2);
4488 3760 : s_return_enable_gc(sc, cons(sc, sc->QUOTE,
4489 : cons(sc, sc->value, sc->NIL)));
4490 :
4491 : CASE(OP_RDQQUOTE):
4492 2687 : gc_disable(sc, 2);
4493 2687 : 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 3871 : gc_disable(sc, 2);
4506 3871 : s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
4507 : cons(sc, sc->value, sc->NIL)));
4508 :
4509 : CASE(OP_RDUQTSP):
4510 2053 : gc_disable(sc, 2);
4511 2053 : 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 38675 : 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 38675 : } else if(is_environment(sc->args)) {
4532 0 : putstr(sc,"#<ENVIRONMENT>");
4533 0 : s_return(sc,sc->T);
4534 38675 : } else if (!is_pair(sc->args)) {
4535 38326 : printatom(sc, sc->args, sc->print_flag);
4536 38326 : s_return(sc,sc->T);
4537 349 : } 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 349 : } 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 349 : } 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 349 : } 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 349 : putstr(sc, "(");
4555 349 : s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4556 349 : sc->args = car(sc->args);
4557 349 : s_thread_to(sc,OP_P0LIST);
4558 : }
4559 :
4560 : CASE(OP_P1LIST):
4561 1517 : if (is_pair(sc->args)) {
4562 1168 : s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4563 1168 : putstr(sc, " ");
4564 1168 : sc->args = car(sc->args);
4565 1168 : s_thread_to(sc,OP_P0LIST);
4566 349 : } 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 349 : if (sc->args != sc->NIL) {
4572 0 : putstr(sc, " . ");
4573 0 : printatom(sc, sc->args, sc->print_flag);
4574 : }
4575 349 : putstr(sc, ")");
4576 349 : 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 73567 : static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
4605 : pointer x, y;
4606 : long v;
4607 :
4608 73567 : switch (op) {
4609 : CASE(OP_LIST_LENGTH): /* length */ /* a.k */
4610 1036 : v=list_length(sc,car(sc->args));
4611 1036 : if(v<0) {
4612 0 : Error_1(sc,"length: not a list:",car(sc->args));
4613 : }
4614 1036 : gc_disable(sc, 1);
4615 1036 : 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 72531 : 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 2966166 : static int is_any(pointer p) {
4668 : (void)p;
4669 2966166 : return 1;
4670 : }
4671 :
4672 71124 : static int is_nonneg(pointer p) {
4673 71124 : 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 2753 : static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
4741 2753 : sc->op = op;
4742 : for (;;) {
4743 32955336 : op_code_info *pcd=dispatch_table+sc->op;
4744 32955336 : if (pcd->name!=0) { /* if built-in function, check arguments */
4745 : char msg[STRBUFFSIZE];
4746 5561292 : int ok=1;
4747 5561292 : int n=list_length(sc,sc->args);
4748 :
4749 : /* Check number of arguments */
4750 5561292 : 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 5561292 : 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 5561292 : if(ok) {
4765 5561292 : if(pcd->arg_tests_encoding!=0) {
4766 4697579 : int i=0;
4767 : int j;
4768 4697579 : const char *t=pcd->arg_tests_encoding;
4769 4697579 : pointer arglist=sc->args;
4770 : do {
4771 6119968 : pointer arg=car(arglist);
4772 6119968 : j=(int)t[0];
4773 6119968 : if(j==TST_LIST[0]) {
4774 2484 : if(arg!=sc->NIL && !is_pair(arg)) break;
4775 : } else {
4776 6117484 : if(!tests[j].fct(arg)) break;
4777 : }
4778 :
4779 6116634 : if(t[1]!=0) {/* last test is replicated as necessary */
4780 93375 : t++;
4781 : }
4782 6116634 : arglist=cdr(arglist);
4783 6116634 : i++;
4784 6116634 : } while(i<n);
4785 4697579 : 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 5561292 : 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 32955336 : ok_to_freely_gc(sc);
4803 32955336 : if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
4804 2752 : return;
4805 : }
4806 32952583 : if(sc->no_memory) {
4807 0 : fprintf(stderr,"No memory!\n");
4808 0 : exit(1);
4809 : }
4810 32952583 : }
4811 : }
4812 :
4813 : /* ========== Initialization of internal keywords ========== */
4814 :
4815 816 : static void assign_syntax(scheme *sc, char *name) {
4816 : pointer x;
4817 :
4818 816 : x = oblist_add_by_name(sc, name);
4819 816 : typeflag(x) |= T_SYNTAX;
4820 816 : }
4821 :
4822 5457 : static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
4823 : pointer x, y;
4824 :
4825 5457 : x = mk_symbol(sc, name);
4826 5457 : y = mk_proc(sc,op);
4827 5457 : new_slot_in_env(sc, x, y);
4828 5457 : }
4829 :
4830 5457 : static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
4831 : pointer y;
4832 :
4833 5457 : y = get_cell(sc, sc->NIL, sc->NIL);
4834 5457 : typeflag(y) = (T_PROC | T_ATOM);
4835 5457 : ivalue_unchecked(y) = (long) op;
4836 5457 : set_num_integer(y);
4837 5457 : return y;
4838 : }
4839 :
4840 : /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
4841 3139510 : static int syntaxnum(pointer p) {
4842 3139510 : const char *s=strvalue(car(p));
4843 3139510 : switch(strlength(car(p))) {
4844 : case 2:
4845 863737 : if(s[0]=='i') return OP_IF0; /* if */
4846 147827 : else return OP_OR0; /* or */
4847 : case 3:
4848 472207 : if(s[0]=='a') return OP_AND0; /* and */
4849 159668 : else return OP_LET0; /* let */
4850 : case 4:
4851 602229 : switch(s[3]) {
4852 0 : case 'e': return OP_CASE0; /* case */
4853 581578 : case 'd': return OP_COND0; /* cond */
4854 14255 : case '*': return OP_LET0AST; /* let* */
4855 6396 : default: return OP_SET0; /* set! */
4856 : }
4857 : case 5:
4858 1072508 : switch(s[2]) {
4859 4956 : case 'g': return OP_BEGIN; /* begin */
4860 138 : case 'l': return OP_DELAY; /* delay */
4861 867 : case 'c': return OP_MACRO0; /* macro */
4862 1066547 : default: return OP_QUOTE; /* quote */
4863 : }
4864 : case 6:
4865 128829 : switch(s[2]) {
4866 74061 : case 'm': return OP_LAMBDA; /* lambda */
4867 54768 : 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 322 : INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
4878 322 : 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 51 : scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
4963 51 : scheme *sc=(scheme*)malloc(sizeof(scheme));
4964 51 : if(!scheme_init_custom_alloc(sc,malloc,free)) {
4965 0 : free(sc);
4966 0 : return 0;
4967 : } else {
4968 51 : 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 51 : int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
4978 51 : int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
4979 : pointer x;
4980 :
4981 51 : num_zero.is_fixnum=1;
4982 51 : num_zero.value.ivalue=0;
4983 51 : num_one.is_fixnum=1;
4984 51 : num_one.value.ivalue=1;
4985 :
4986 : #if USE_INTERFACE
4987 51 : sc->vptr=&vtbl;
4988 : #endif
4989 51 : sc->gensym_cnt=0;
4990 51 : sc->malloc=malloc;
4991 51 : sc->free=free;
4992 51 : sc->last_cell_seg = -1;
4993 51 : sc->sink = &sc->_sink;
4994 51 : sc->NIL = &sc->_NIL;
4995 51 : sc->T = &sc->_HASHT;
4996 51 : sc->F = &sc->_HASHF;
4997 51 : sc->EOF_OBJ=&sc->_EOF_OBJ;
4998 :
4999 : #if USE_SMALL_INTEGERS
5000 51 : if (initialize_small_integers(sc)) {
5001 0 : sc->no_memory=1;
5002 0 : return 0;
5003 : }
5004 : #endif
5005 :
5006 51 : sc->free_cell = &sc->_NIL;
5007 51 : sc->fcells = 0;
5008 51 : sc->inhibit_gc = GC_ENABLED;
5009 51 : sc->reserved_cells = 0;
5010 51 : sc->reserved_lineno = 0;
5011 51 : sc->no_memory=0;
5012 51 : sc->inport=sc->NIL;
5013 51 : sc->outport=sc->NIL;
5014 51 : sc->save_inport=sc->NIL;
5015 51 : sc->loadport=sc->NIL;
5016 51 : sc->nesting=0;
5017 51 : memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
5018 51 : sc->interactive_repl=0;
5019 51 : sc->strbuff = sc->malloc(STRBUFFSIZE);
5020 51 : if (sc->strbuff == 0) {
5021 0 : sc->no_memory=1;
5022 0 : return 0;
5023 : }
5024 51 : sc->strbuff_size = STRBUFFSIZE;
5025 :
5026 51 : if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
5027 0 : sc->no_memory=1;
5028 0 : return 0;
5029 : }
5030 51 : sc->gc_verbose = 0;
5031 51 : dump_stack_initialize(sc);
5032 51 : sc->code = sc->NIL;
5033 51 : sc->tracing=0;
5034 :
5035 : /* init sc->NIL */
5036 51 : typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
5037 51 : car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
5038 : /* init T */
5039 51 : typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
5040 51 : car(sc->T) = cdr(sc->T) = sc->T;
5041 : /* init F */
5042 51 : typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
5043 51 : car(sc->F) = cdr(sc->F) = sc->F;
5044 : /* init EOF_OBJ */
5045 51 : typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
5046 51 : car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
5047 : /* init sink */
5048 51 : typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
5049 51 : car(sc->sink) = cdr(sc->sink) = sc->NIL;
5050 : /* init c_nest */
5051 51 : sc->c_nest = sc->NIL;
5052 :
5053 51 : sc->oblist = oblist_initial_value(sc);
5054 : /* init global_env */
5055 51 : new_frame_in_env(sc, sc->NIL);
5056 51 : sc->global_env = sc->envir;
5057 : /* init else */
5058 51 : x = mk_symbol(sc,"else");
5059 51 : new_slot_in_env(sc, x, sc->T);
5060 :
5061 51 : assign_syntax(sc, "lambda");
5062 51 : assign_syntax(sc, "quote");
5063 51 : assign_syntax(sc, "define");
5064 51 : assign_syntax(sc, "if");
5065 51 : assign_syntax(sc, "begin");
5066 51 : assign_syntax(sc, "set!");
5067 51 : assign_syntax(sc, "let");
5068 51 : assign_syntax(sc, "let*");
5069 51 : assign_syntax(sc, "letrec");
5070 51 : assign_syntax(sc, "cond");
5071 51 : assign_syntax(sc, "delay");
5072 51 : assign_syntax(sc, "and");
5073 51 : assign_syntax(sc, "or");
5074 51 : assign_syntax(sc, "cons-stream");
5075 51 : assign_syntax(sc, "macro");
5076 51 : assign_syntax(sc, "case");
5077 :
5078 8517 : for(i=0; i<n; i++) {
5079 8466 : if(dispatch_table[i].name!=0) {
5080 5457 : assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
5081 : }
5082 : }
5083 :
5084 : /* initialization of global pointers to special symbols */
5085 51 : sc->LAMBDA = mk_symbol(sc, "lambda");
5086 51 : sc->QUOTE = mk_symbol(sc, "quote");
5087 51 : sc->QQUOTE = mk_symbol(sc, "quasiquote");
5088 51 : sc->UNQUOTE = mk_symbol(sc, "unquote");
5089 51 : sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
5090 51 : sc->FEED_TO = mk_symbol(sc, "=>");
5091 51 : sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
5092 51 : sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
5093 51 : sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
5094 : #if USE_COMPILE_HOOK
5095 51 : sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
5096 : #endif
5097 :
5098 51 : return !sc->no_memory;
5099 : }
5100 :
5101 51 : void scheme_set_input_port_file(scheme *sc, FILE *fin) {
5102 51 : sc->inport=port_from_file(sc,fin,port_input);
5103 51 : }
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 51 : void scheme_set_output_port_file(scheme *sc, FILE *fout) {
5110 51 : sc->outport=port_from_file(sc,fout,port_output);
5111 51 : }
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 50 : void scheme_deinit(scheme *sc) {
5122 : int i;
5123 :
5124 : #if SHOW_ERROR_LINE
5125 : char *fname;
5126 : #endif
5127 :
5128 50 : sc->oblist=sc->NIL;
5129 50 : sc->global_env=sc->NIL;
5130 50 : dump_stack_free(sc);
5131 50 : sc->envir=sc->NIL;
5132 50 : sc->code=sc->NIL;
5133 50 : sc->args=sc->NIL;
5134 50 : sc->value=sc->NIL;
5135 50 : if(is_port(sc->inport)) {
5136 0 : typeflag(sc->inport) = T_ATOM;
5137 : }
5138 50 : sc->inport=sc->NIL;
5139 50 : sc->outport=sc->NIL;
5140 50 : if(is_port(sc->save_inport)) {
5141 0 : typeflag(sc->save_inport) = T_ATOM;
5142 : }
5143 50 : sc->save_inport=sc->NIL;
5144 50 : if(is_port(sc->loadport)) {
5145 0 : typeflag(sc->loadport) = T_ATOM;
5146 : }
5147 50 : sc->loadport=sc->NIL;
5148 50 : sc->gc_verbose=0;
5149 50 : gc(sc,sc->NIL,sc->NIL);
5150 :
5151 : #if USE_SMALL_INTEGERS
5152 50 : sc->free(sc->integer_alloc);
5153 : #endif
5154 :
5155 200 : for(i=0; i<=sc->last_cell_seg; i++) {
5156 150 : sc->free(sc->alloc_seg[i]);
5157 : }
5158 50 : sc->free(sc->strbuff);
5159 :
5160 : #if SHOW_ERROR_LINE
5161 100 : for(i=0; i<=sc->file_i; i++) {
5162 50 : 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 50 : }
5170 :
5171 0 : void scheme_load_file(scheme *sc, FILE *fin)
5172 0 : { scheme_load_named_file(sc,fin,0); }
5173 :
5174 306 : void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
5175 306 : dump_stack_reset(sc);
5176 306 : sc->envir = sc->global_env;
5177 306 : sc->file_i=0;
5178 306 : sc->load_stack[0].kind=port_input|port_file;
5179 306 : sc->load_stack[0].rep.stdio.file=fin;
5180 306 : sc->loadport=mk_port(sc,sc->load_stack);
5181 306 : sc->retcode=0;
5182 306 : if(fin==stdin) {
5183 0 : sc->interactive_repl=1;
5184 : }
5185 :
5186 : #if SHOW_ERROR_LINE
5187 306 : sc->load_stack[0].rep.stdio.curr_line = 0;
5188 306 : if(fin!=stdin && filename)
5189 306 : 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 306 : sc->inport=sc->loadport;
5195 306 : sc->args = mk_integer(sc,sc->file_i);
5196 306 : Eval_Cycle(sc, OP_T0LVL);
5197 305 : typeflag(sc->loadport)=T_ATOM;
5198 305 : if(sc->retcode==0) {
5199 305 : sc->retcode=sc->nesting!=0;
5200 : }
5201 :
5202 : #if SHOW_ERROR_LINE
5203 305 : sc->free(sc->load_stack[0].rep.stdio.filename);
5204 305 : sc->load_stack[0].rep.stdio.filename = NULL;
5205 : #endif
5206 305 : }
5207 :
5208 2447 : void scheme_load_string(scheme *sc, const char *cmd) {
5209 2447 : dump_stack_reset(sc);
5210 2447 : sc->envir = sc->global_env;
5211 2447 : sc->file_i=0;
5212 2447 : sc->load_stack[0].kind=port_input|port_string;
5213 2447 : sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
5214 2447 : sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
5215 2447 : sc->load_stack[0].rep.string.curr=(char*)cmd;
5216 2447 : sc->loadport=mk_port(sc,sc->load_stack);
5217 2447 : sc->retcode=0;
5218 2447 : sc->interactive_repl=0;
5219 2447 : sc->inport=sc->loadport;
5220 2447 : sc->args = mk_integer(sc,sc->file_i);
5221 2447 : Eval_Cycle(sc, OP_T0LVL);
5222 2447 : typeflag(sc->loadport)=T_ATOM;
5223 2447 : if(sc->retcode==0) {
5224 2447 : sc->retcode=sc->nesting!=0;
5225 : }
5226 2447 : }
5227 :
5228 3468 : void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
5229 : pointer x;
5230 :
5231 3468 : x=find_slot_in_env(sc,envir,symbol,0);
5232 3468 : if (x != sc->NIL) {
5233 0 : set_slot_in_env(sc, x, value);
5234 : } else {
5235 3468 : new_slot_spec_in_env(sc, envir, symbol, value);
5236 : }
5237 3468 : }
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 : */
|
