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