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