26 #define _SCHEME_SOURCE
47 #define stricmp strcasecmp
65 #define TOK_SHARP_CONST 11
74 #define banner "TinyScheme 1.35"
86 stricmp(
const char* s1,
const char* s2) {
106 *s = tolower((
int)*s);
118 #define InitFile "init.scm"
121 #ifndef FIRST_CELLSEGS
122 #define FIRST_CELLSEGS 3
140 T_LAST_SYSTEM_TYPE = 14
146 #define T_MASKTYPE 31
147 #define T_SYNTAX 4096
148 #define T_IMMUTABLE 8192
150 #define CLRATOM 49151
154 static num num_add(num a, num b);
155 static num num_mul(num a, num b);
156 static num num_div(num a, num b);
157 static num num_intdiv(num a, num b);
158 static num num_sub(num a, num b);
159 static num num_rem(num a, num b);
160 static num num_mod(num a, num b);
161 static int num_eq(num a, num b);
162 static int num_gt(num a, num b);
163 static int num_ge(num a, num b);
164 static int num_lt(num a, num b);
165 static int num_le(num a, num b);
168 static double round_per_R5RS(
double x);
170 static int is_zero_double(
double x);
176 #define typeflag(p) ((p)->_flag)
177 #define type(p) (typeflag(p) & T_MASKTYPE)
180 is_string(pointer p) {
181 return (type(p) == T_STRING);
184 #define strvalue(p) ((p)->_object._string._svalue)
185 #define strlength(p) ((p)->_object._string._length)
188 is_vector(pointer p) {
189 return (type(p) == T_VECTOR);
192 INTERFACE
static void fill_vector(pointer vec, pointer obj);
193 INTERFACE
static pointer vector_elem(pointer vec,
int ielem);
194 INTERFACE
static pointer set_vector_elem(pointer vec,
int ielem, pointer a);
197 is_number(pointer p) {
198 return (type(p) == T_NUMBER);
202 is_integer(pointer p) {
203 return ((p)->_object._number.is_fixnum);
208 return (!(p)->_object._number.is_fixnum);
212 is_character(pointer p) {
213 return (type(p) == T_CHARACTER);
216 INTERFACE INLINE
char*
217 string_value(pointer p) {
223 return ((p)->_object._number);
228 return (is_integer(p) ? (p)->_object._number.value.ivalue : (
long)(p)->_object._number.value.rvalue);
233 return (!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_integer(p) (p)->_object._number.is_fixnum = 1;
239 #define set_real(p) (p)->_object._number.is_fixnum = 0;
242 charvalue(pointer p) {
243 return ivalue_unchecked(p);
248 return (type(p) == T_PORT);
251 #define is_inport(p) (type(p) == T_PORT && p->_object._port->kind & port_input)
252 #define is_outport(p) (type(p) == T_PORT && p->_object._port->kind & port_output)
256 return (type(p) == T_PAIR);
259 #define car(p) ((p)->_object._cons._car)
260 #define cdr(p) ((p)->_object._cons._cdr)
263 pair_car(pointer p) {
268 pair_cdr(pointer p) {
273 set_car(pointer p, pointer q) {
278 set_cdr(pointer p, pointer q) {
283 is_symbol(pointer p) {
284 return (type(p) == T_SYMBOL);
287 INTERFACE INLINE
char*
289 return strvalue(car(p));
292 SCHEME_EXPORT INLINE
int
294 return (typeflag(p) & T_SYMBOL);
297 #define symprop(p) cdr(p)
301 is_syntax(pointer p) {
302 return (typeflag(p) & T_SYNTAX);
307 return (type(p) == T_PROC);
311 is_foreign(pointer p) {
312 return (type(p) == T_FOREIGN);
315 INTERFACE INLINE
char*
316 syntaxname(pointer p) {
317 return strvalue(car(p));
320 #define procnum(p) ivalue(p)
321 static const char* procname(pointer x);
324 is_closure(pointer p) {
325 return (type(p) == T_CLOSURE);
329 is_macro(pointer p) {
330 return (type(p) == T_MACRO);
333 INTERFACE INLINE pointer
334 closure_code(pointer p) {
338 INTERFACE INLINE pointer
339 closure_env(pointer p) {
344 is_continuation(pointer p) {
345 return (type(p) == T_CONTINUATION);
348 #define cont_dump(p) cdr(p)
352 is_promise(pointer p) {
353 return (type(p) == T_PROMISE);
357 is_environment(pointer p) {
358 return (type(p) == T_ENVIRONMENT);
361 #define setenvironment(p) typeflag(p) = T_ENVIRONMENT
363 #define is_atom(p) (typeflag(p) & T_ATOM)
364 #define setatom(p) typeflag(p) |= T_ATOM
365 #define clratom(p) typeflag(p) &= CLRATOM
367 #define is_mark(p) (typeflag(p) & MARK)
368 #define setmark(p) typeflag(p) |= MARK
369 #define clrmark(p) typeflag(p) &= UNMARK
372 is_immutable(pointer p) {
373 return (typeflag(p) & T_IMMUTABLE);
377 INTERFACE INLINE
void
378 setimmutable(pointer p) {
379 typeflag(p) |= T_IMMUTABLE;
382 #define caar(p) car(car(p))
383 #define cadr(p) car(cdr(p))
384 #define cdar(p) cdr(car(p))
385 #define cddr(p) cdr(cdr(p))
386 #define cadar(p) car(cdr(car(p)))
387 #define caddr(p) car(cdr(cdr(p)))
388 #define cadaar(p) car(cdr(car(car(p))))
389 #define cadddr(p) car(cdr(cdr(cdr(p))))
390 #define cddddr(p) cdr(cdr(cdr(cdr(p))))
392 #if USE_CHAR_CLASSIFIERS
395 return isascii(c) && isalpha(c);
400 return isascii(c) && isdigit(c);
405 return isascii(c) && isspace(c);
410 return isascii(c) && isupper(c);
415 return isascii(c) && islower(c);
420 static const char* charnames[32] = {
"nul",
"soh",
"stx",
"etx",
"eot",
"enq",
"ack",
"bel",
"bs",
"ht",
"lf",
421 "vt",
"ff",
"cr",
"so",
"si",
"dle",
"dc1",
"dc2",
"dc3",
"dc4",
"nak",
422 "syn",
"etb",
"can",
"em",
"sub",
"esc",
"fs",
"gs",
"rs",
"us" };
425 is_ascii_name(
const char* name,
int* pc) {
427 for (i = 0; i < 32; i++) {
428 if (stricmp(name, charnames[i]) == 0) {
433 if (stricmp(name,
"del") == 0) {
442 static int file_push(scheme* sc,
const char* fname);
443 static void file_pop(scheme* sc);
444 static int file_interactive(scheme* sc);
445 static INLINE
int is_one_of(
char* s,
int c);
446 static int alloc_cellseg(scheme* sc,
int n);
447 static long binary_decode(
const char* s);
448 static INLINE pointer get_cell(scheme* sc, pointer a, pointer b);
449 static pointer _get_cell(scheme* sc, pointer a, pointer b);
450 static pointer get_consecutive_cells(scheme* sc,
int n);
451 static pointer find_consecutive_cells(scheme* sc,
int n);
452 static void finalize_cell(scheme* sc, pointer a);
453 static int count_consecutive_cells(pointer x,
int needed);
454 static pointer find_slot_in_env(scheme* sc, pointer env, pointer sym,
int all);
455 static pointer mk_number(scheme* sc, num n);
456 static pointer mk_empty_string(scheme* sc,
int len,
char fill);
457 static char* store_string(scheme* sc,
int len,
const char* str,
char fill);
458 static pointer mk_vector(scheme* sc,
int len);
459 static pointer mk_atom(scheme* sc,
char* q);
460 static pointer mk_sharp_const(scheme* sc,
char* name);
461 static pointer mk_port(scheme* sc, port* p);
462 static pointer port_from_filename(scheme* sc,
const char* fn,
int prop);
463 static pointer port_from_file(scheme* sc, FILE*,
int prop);
464 static pointer port_from_string(scheme* sc,
char* start,
char* past_the_end,
int prop);
465 static port* port_rep_from_filename(scheme* sc,
const char* fn,
int prop);
466 static port* port_rep_from_file(scheme* sc, FILE*,
int prop);
467 static port* port_rep_from_string(scheme* sc,
char* start,
char* past_the_end,
int prop);
468 static void port_close(scheme* sc, pointer p,
int flag);
469 static void mark(pointer a);
470 static void gc(scheme* sc, pointer a, pointer b);
471 static int basic_inchar(port* pt);
472 static int inchar(scheme* sc);
473 static void backchar(scheme* sc,
int c);
474 static char* readstr_upto(scheme* sc,
char* delim);
475 static pointer readstrexp(scheme* sc);
476 static INLINE
void skipspace(scheme* sc);
477 static int token(scheme* sc);
478 static void printslashstring(scheme* sc,
char* s,
int len);
479 static void atom2str(scheme* sc, pointer l,
int f,
char** pp,
int* plen);
480 static void printatom(scheme* sc, pointer l,
int f);
481 static pointer mk_proc(scheme* sc,
enum scheme_opcodes op);
482 static pointer mk_closure(scheme* sc, pointer c, pointer e);
483 static pointer mk_continuation(scheme* sc, pointer d);
484 static pointer reverse(scheme* sc, pointer a);
485 static pointer reverse_in_place(scheme* sc, pointer term, pointer list);
486 static pointer append(scheme* sc, pointer a, pointer b);
487 static int list_length(scheme* sc, pointer a);
488 static int eqv(pointer a, pointer b);
489 static void dump_stack_mark(scheme*);
490 static pointer opexe_0(scheme* sc,
enum scheme_opcodes op);
491 static pointer opexe_1(scheme* sc,
enum scheme_opcodes op);
492 static pointer opexe_2(scheme* sc,
enum scheme_opcodes op);
493 static pointer opexe_3(scheme* sc,
enum scheme_opcodes op);
494 static pointer opexe_4(scheme* sc,
enum scheme_opcodes op);
495 static pointer opexe_5(scheme* sc,
enum scheme_opcodes op);
496 static pointer opexe_6(scheme* sc,
enum scheme_opcodes op);
497 static void Eval_Cycle(scheme* sc,
enum scheme_opcodes op);
498 static void assign_syntax(scheme* sc,
char* name);
499 static int syntaxnum(pointer p);
500 static void assign_proc(scheme* sc,
enum scheme_opcodes,
char* name);
502 #define num_ivalue(n) (n.is_fixnum ? (n).value.ivalue : (long)(n).value.rvalue)
503 #define num_rvalue(n) (!n.is_fixnum ? (n).value.rvalue : (double)(n).value.ivalue)
506 num_add(num a, num b) {
508 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
510 ret.value.ivalue = a.value.ivalue + b.value.ivalue;
512 ret.value.rvalue = num_rvalue(a) + num_rvalue(b);
518 num_mul(num a, num b) {
520 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
522 ret.value.ivalue = a.value.ivalue * b.value.ivalue;
524 ret.value.rvalue = num_rvalue(a) * num_rvalue(b);
530 num_div(num a, num b) {
532 ret.is_fixnum = a.is_fixnum && b.is_fixnum && a.value.ivalue % b.value.ivalue == 0;
534 ret.value.ivalue = a.value.ivalue / b.value.ivalue;
536 ret.value.rvalue = num_rvalue(a) / num_rvalue(b);
542 num_intdiv(num a, num b) {
544 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
546 ret.value.ivalue = a.value.ivalue / b.value.ivalue;
548 ret.value.rvalue = num_rvalue(a) / num_rvalue(b);
554 num_sub(num a, num b) {
556 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
558 ret.value.ivalue = a.value.ivalue - b.value.ivalue;
560 ret.value.rvalue = num_rvalue(a) - num_rvalue(b);
566 num_rem(num a, num b) {
569 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
578 }
else if (res < 0) {
583 ret.value.ivalue = res;
588 num_mod(num a, num b) {
591 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
603 ret.value.ivalue = res;
608 num_eq(num a, num b) {
610 int is_fixnum = a.is_fixnum && b.is_fixnum;
612 ret = a.value.ivalue == b.value.ivalue;
614 ret = num_rvalue(a) == num_rvalue(b);
620 num_gt(num a, num b) {
622 int is_fixnum = a.is_fixnum && b.is_fixnum;
624 ret = a.value.ivalue > b.value.ivalue;
626 ret = num_rvalue(a) > num_rvalue(b);
632 num_ge(num a, num b) {
633 return !num_lt(a, b);
637 num_lt(num a, num b) {
639 int is_fixnum = a.is_fixnum && b.is_fixnum;
641 ret = a.value.ivalue < b.value.ivalue;
643 ret = num_rvalue(a) < num_rvalue(b);
649 num_le(num a, num b) {
650 return !num_gt(a, b);
656 round_per_R5RS(
double x) {
657 double fl = floor(x);
663 }
else if (dfl < dce) {
666 if (fmod(fl, 2.0) == 0.0) {
676 is_zero_double(
double x) {
677 return x < DBL_MIN && x > -DBL_MIN;
681 binary_decode(
const char* s) {
684 while (*s != 0 && (*s ==
'1' || *s ==
'0')) {
695 alloc_cellseg(scheme* sc,
int n) {
704 if (adj <
sizeof(
struct cell)) {
705 adj =
sizeof(
struct cell);
708 for (k = 0; k < n; k++) {
709 if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
711 cp = (
char*)sc->malloc(CELL_SEGSIZE *
sizeof(
struct cell) + adj);
714 i = ++sc->last_cell_seg;
715 sc->alloc_seg[i] = cp;
718 static_assert(
sizeof(
size_t) ==
sizeof(cp),
"Can't cast pointer to size_t.");
719 if ((
size_t)cp % adj != 0) {
720 cp = (
char*)(adj * ((
size_t)cp / adj + 1));
724 sc->cell_seg[i] = newp;
725 while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
727 sc->cell_seg[i] = sc->cell_seg[i - 1];
728 sc->cell_seg[--i] = p;
730 sc->fcells += CELL_SEGSIZE;
731 last = newp + CELL_SEGSIZE - 1;
732 for (p = newp; p <= last; p++) {
738 if (sc->free_cell == sc->NIL || p < sc->free_cell) {
739 cdr(last) = sc->free_cell;
740 sc->free_cell = newp;
743 while (cdr(p) != sc->NIL && newp > cdr(p))
752 static INLINE pointer
753 get_cell(scheme* sc, pointer a, pointer b) {
754 if (sc->free_cell != sc->NIL) {
755 pointer x = sc->free_cell;
756 sc->free_cell = cdr(x);
760 return _get_cell(sc, a, b);
765 _get_cell(scheme* sc, pointer a, pointer b) {
772 if (sc->free_cell == sc->NIL) {
774 if (sc->fcells < sc->last_cell_seg * 8 || sc->free_cell == sc->NIL) {
776 if (!alloc_cellseg(sc, 1) && sc->free_cell == sc->NIL) {
783 sc->free_cell = cdr(x);
789 get_consecutive_cells(scheme* sc,
int n) {
797 x = find_consecutive_cells(sc, n);
800 gc(sc, sc->NIL, sc->NIL);
801 x = find_consecutive_cells(sc, n);
804 if (!alloc_cellseg(sc, 1)) {
809 x = find_consecutive_cells(sc, n);
820 count_consecutive_cells(pointer x,
int needed) {
822 while (cdr(x) == x + 1) {
832 find_consecutive_cells(scheme* sc,
int n) {
837 while (*pp != sc->NIL) {
838 cnt = count_consecutive_cells(*pp, n);
841 *pp = cdr(*pp + n - 1);
845 pp = &cdr(*pp + cnt - 1);
852 _cons(scheme* sc, pointer a, pointer b,
int immutable) {
853 pointer x = get_cell(sc, a, b);
855 typeflag(x) = T_PAIR;
866 #ifndef USE_OBJECT_LIST
868 static int hash_fn(
const char* key,
int table_size);
871 oblist_initial_value(scheme* sc) {
872 return mk_vector(sc, 461);
877 oblist_add_by_name(scheme* sc,
const char* name) {
881 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
882 typeflag(x) = T_SYMBOL;
883 setimmutable(car(x));
885 location = hash_fn(name, ivalue_unchecked(sc->oblist));
886 set_vector_elem(sc->oblist, location, immutable_cons(sc, x, vector_elem(sc->oblist, location)));
890 static INLINE pointer
891 oblist_find_by_name(scheme* sc,
const char* name) {
896 location = hash_fn(name, ivalue_unchecked(sc->oblist));
897 for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
900 if (stricmp(name, s) == 0) {
908 oblist_all_symbols(scheme* sc) {
911 pointer ob_list = sc->NIL;
913 for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
914 for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
915 ob_list = cons(sc, x, ob_list);
924 oblist_initial_value(scheme* sc) {
928 static INLINE pointer
929 oblist_find_by_name(scheme* sc,
const char* name) {
933 for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
936 if (stricmp(name, s) == 0) {
945 oblist_add_by_name(scheme* sc,
const char* name) {
948 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
949 typeflag(x) = T_SYMBOL;
950 setimmutable(car(x));
951 sc->oblist = immutable_cons(sc, x, sc->oblist);
956 oblist_all_symbols(scheme* sc) {
963 mk_port(scheme* sc, port* p) {
964 pointer x = get_cell(sc, sc->NIL, sc->NIL);
966 typeflag(x) = T_PORT | T_ATOM;
967 x->_object._port = p;
972 mk_foreign_func(scheme* sc, foreign_func f) {
973 pointer x = get_cell(sc, sc->NIL, sc->NIL);
975 typeflag(x) = (T_FOREIGN | T_ATOM);
981 mk_character(scheme* sc,
int c) {
982 pointer x = get_cell(sc, sc->NIL, sc->NIL);
984 typeflag(x) = (T_CHARACTER | T_ATOM);
985 ivalue_unchecked(x) = c;
992 mk_integer(scheme* sc,
long num) {
993 pointer x = get_cell(sc, sc->NIL, sc->NIL);
995 typeflag(x) = (T_NUMBER | T_ATOM);
996 ivalue_unchecked(x) = num;
1002 mk_real(scheme* sc,
double n) {
1003 pointer x = get_cell(sc, sc->NIL, sc->NIL);
1005 typeflag(x) = (T_NUMBER | T_ATOM);
1006 rvalue_unchecked(x) = n;
1012 mk_number(scheme* sc, num n) {
1014 return mk_integer(sc, n.value.ivalue);
1016 return mk_real(sc, n.value.rvalue);
1022 store_string(scheme* sc,
int len_str,
const char* str,
char fill) {
1025 q = (
char*)sc->malloc(len_str + 1);
1033 memset(q, fill, len_str);
1041 mk_string(scheme* sc,
const char* str) {
1042 return mk_counted_string(sc, str, strlen(str));
1046 mk_counted_string(scheme* sc,
const char* str,
int len) {
1047 pointer x = get_cell(sc, sc->NIL, sc->NIL);
1049 strvalue(x) = store_string(sc, len, str, 0);
1050 typeflag(x) = (T_STRING | T_ATOM);
1056 mk_empty_string(scheme* sc,
int len,
char fill) {
1057 pointer x = get_cell(sc, sc->NIL, sc->NIL);
1059 strvalue(x) = store_string(sc, len, 0, fill);
1060 typeflag(x) = (T_STRING | T_ATOM);
1065 INTERFACE
static pointer
1066 mk_vector(scheme* sc,
int len) {
1067 pointer x = get_consecutive_cells(sc, len / 2 + len % 2 + 1);
1068 typeflag(x) = (T_VECTOR | T_ATOM);
1069 ivalue_unchecked(x) = len;
1071 fill_vector(x, sc->NIL);
1075 INTERFACE
static void
1076 fill_vector(pointer vec, pointer obj) {
1078 int num = ivalue(vec) / 2 + ivalue(vec) % 2;
1079 for (i = 0; i < num; i++) {
1080 typeflag(vec + 1 + i) = T_PAIR;
1081 setimmutable(vec + 1 + i);
1082 car(vec + 1 + i) = obj;
1083 cdr(vec + 1 + i) = obj;
1087 INTERFACE
static pointer
1088 vector_elem(pointer vec,
int ielem) {
1090 if (ielem % 2 == 0) {
1091 return car(vec + 1 + n);
1093 return cdr(vec + 1 + n);
1097 INTERFACE
static pointer
1098 set_vector_elem(pointer vec,
int ielem, pointer a) {
1100 if (ielem % 2 == 0) {
1101 return car(vec + 1 + n) = a;
1103 return cdr(vec + 1 + n) = a;
1109 mk_symbol(scheme* sc,
const char* name) {
1113 x = oblist_find_by_name(sc, name);
1117 x = oblist_add_by_name(sc, name);
1123 gensym(scheme* sc) {
1127 for (; sc->gensym_cnt < LONG_MAX; sc->gensym_cnt++) {
1128 sprintf(name,
"gensym-%ld", sc->gensym_cnt);
1131 x = oblist_find_by_name(sc, name);
1136 x = oblist_add_by_name(sc, name);
1146 mk_atom(scheme* sc,
char* q) {
1148 int has_dec_point = 0;
1152 if ((p = strstr(q,
"::")) != 0) {
1157 sc, cons(sc, sc->QUOTE, cons(sc, mk_atom(sc, p + 2), sc->NIL)),
1158 cons(sc, mk_symbol(sc, strlwr(q)), sc->NIL)
1166 if ((c ==
'+') || (c ==
'-')) {
1172 if (!isdigit((
int)c)) {
1173 return (mk_symbol(sc, strlwr(q)));
1175 }
else if (c ==
'.') {
1178 if (!isdigit((
int)c)) {
1179 return (mk_symbol(sc, strlwr(q)));
1181 }
else if (!isdigit((
int)c)) {
1182 return (mk_symbol(sc, strlwr(q)));
1185 for (; (c = *p) != 0; ++p) {
1186 if (!isdigit((
int)c)) {
1188 if (!has_dec_point) {
1192 }
else if ((c ==
'e') || (c ==
'E')) {
1197 if ((*p ==
'-') || (*p ==
'+') || isdigit((
int)*p)) {
1202 return (mk_symbol(sc, strlwr(q)));
1205 if (has_dec_point) {
1206 return mk_real(sc, atof(q));
1208 return (mk_integer(sc, atol(q)));
1213 mk_sharp_const(scheme* sc,
char* name) {
1217 if (!strcmp(name,
"t"))
1219 else if (!strcmp(name,
"f"))
1221 else if (*name ==
'o') {
1222 sprintf(tmp,
"0%s", name + 1);
1223 sscanf(tmp,
"%lo", &x);
1224 return (mk_integer(sc, x));
1225 }
else if (*name ==
'd') {
1226 sscanf(name + 1,
"%ld", &x);
1227 return (mk_integer(sc, x));
1228 }
else if (*name ==
'x') {
1229 sprintf(tmp,
"0x%s", name + 1);
1230 sscanf(tmp,
"%lx", &x);
1231 return (mk_integer(sc, x));
1232 }
else if (*name ==
'b') {
1233 x = binary_decode(name + 1);
1234 return (mk_integer(sc, x));
1235 }
else if (*name ==
'\\') {
1237 if (stricmp(name + 1,
"space") == 0) {
1239 }
else if (stricmp(name + 1,
"newline") == 0) {
1241 }
else if (stricmp(name + 1,
"return") == 0) {
1243 }
else if (stricmp(name + 1,
"tab") == 0) {
1245 }
else if (name[1] ==
'x' && name[2] != 0) {
1247 if (sscanf(name + 2,
"%x", &c1) == 1 && c1 < 256) {
1253 }
else if (is_ascii_name(name + 1, &c)) {
1256 }
else if (name[2] == 0) {
1261 return mk_character(sc, c);
1283 int num = ivalue_unchecked(p) / 2 + ivalue_unchecked(p) % 2;
1284 for (i = 0; i < num; i++) {
1293 if (q && !is_mark(q)) {
1302 if (q && !is_mark(q)) {
1328 gc(scheme* sc, pointer a, pointer b) {
1332 if (sc->gc_verbose) {
1333 putstr(sc,
"gc...");
1338 mark(sc->global_env);
1344 dump_stack_mark(sc);
1347 mark(sc->save_inport);
1358 sc->free_cell = sc->NIL;
1364 for (i = sc->last_cell_seg; i >= 0; i--) {
1365 p = sc->cell_seg[i] + CELL_SEGSIZE;
1366 while (--p >= sc->cell_seg[i]) {
1371 if (typeflag(p) != 0) {
1372 finalize_cell(sc, p);
1377 cdr(p) = sc->free_cell;
1383 if (sc->gc_verbose) {
1385 sprintf(msg,
"done: %ld cells were recovered.\n", sc->fcells);
1391 finalize_cell(scheme* sc, pointer a) {
1393 sc->free(strvalue(a));
1394 }
else if (is_port(a)) {
1395 if (a->_object._port->kind & port_file && a->_object._port->rep.stdio.closeit) {
1396 port_close(sc, a, port_input | port_output);
1398 sc->free(a->_object._port);
1405 file_push(scheme* sc,
const char* fname) {
1406 FILE* fin = fopen(fname,
"r");
1409 sc->load_stack[sc->file_i].kind = port_file | port_input;
1410 sc->load_stack[sc->file_i].rep.stdio.file = fin;
1411 sc->load_stack[sc->file_i].rep.stdio.closeit = 1;
1412 sc->nesting_stack[sc->file_i] = 0;
1413 sc->loadport->_object._port = sc->load_stack + sc->file_i;
1419 file_pop(scheme* sc) {
1420 sc->nesting = sc->nesting_stack[sc->file_i];
1421 if (sc->file_i != 0) {
1422 port_close(sc, sc->loadport, port_input);
1424 sc->loadport->_object._port = sc->load_stack + sc->file_i;
1425 if (file_interactive(sc)) {
1432 file_interactive(scheme* sc) {
1433 return sc->file_i == 0 && sc->load_stack[0].rep.stdio.file == stdin && sc->inport->_object._port->kind & port_file;
1437 port_rep_from_filename(scheme* sc,
const char* fn,
int prop) {
1441 if (prop == (port_input | port_output)) {
1443 }
else if (prop == port_output) {
1452 pt = port_rep_from_file(sc, f, prop);
1453 pt->rep.stdio.closeit = 1;
1458 port_from_filename(scheme* sc,
const char* fn,
int prop) {
1460 pt = port_rep_from_filename(sc, fn, prop);
1464 return mk_port(sc, pt);
1468 port_rep_from_file(scheme* sc, FILE* f,
int prop) {
1471 pt = (port*)sc->malloc(
sizeof(port));
1484 pt->kind = port_file | prop;
1485 pt->rep.stdio.file = f;
1486 pt->rep.stdio.closeit = 0;
1491 port_from_file(scheme* sc, FILE* f,
int prop) {
1493 pt = port_rep_from_file(sc, f, prop);
1497 return mk_port(sc, pt);
1501 port_rep_from_string(scheme* sc,
char* start,
char* past_the_end,
int prop) {
1503 pt = (port*)sc->malloc(
sizeof(port));
1507 pt->kind = port_string | prop;
1508 pt->rep.string.start = start;
1509 pt->rep.string.curr = start;
1510 pt->rep.string.past_the_end = past_the_end;
1515 port_from_string(scheme* sc,
char* start,
char* past_the_end,
int prop) {
1517 pt = port_rep_from_string(sc, start, past_the_end, prop);
1521 return mk_port(sc, pt);
1525 port_close(scheme* sc, pointer p,
int flag) {
1526 port* pt = p->_object._port;
1528 if ((pt->kind & (port_input | port_output)) == 0) {
1529 if (pt->kind & port_file) {
1530 fclose(pt->rep.stdio.file);
1532 pt->kind = port_free;
1538 inchar(scheme* sc) {
1542 pt = sc->inport->_object._port;
1543 c = basic_inchar(pt);
1544 if (c == EOF && sc->inport == sc->loadport && sc->file_i != 0) {
1546 if (sc->nesting != 0) {
1555 basic_inchar(port* pt) {
1556 if (pt->kind & port_file) {
1557 return fgetc(pt->rep.stdio.file);
1559 if (*pt->rep.string.curr == 0 || pt->rep.string.curr == pt->rep.string.past_the_end) {
1562 return *pt->rep.string.curr++;
1569 backchar(scheme* sc,
int c) {
1573 pt = sc->inport->_object._port;
1574 if (pt->kind & port_file) {
1575 ungetc(c, pt->rep.stdio.file);
1577 if (pt->rep.string.curr != pt->rep.string.start) {
1578 --pt->rep.string.curr;
1584 putstr(scheme* sc,
const char* s) {
1585 port* pt = sc->outport->_object._port;
1586 if (pt->kind & port_file) {
1587 fputs(s, pt->rep.stdio.file);
1590 if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1591 *pt->rep.string.curr++ = *s;
1598 putchars(scheme* sc,
const char* s,
int len) {
1599 port* pt = sc->outport->_object._port;
1600 if (pt->kind & port_file) {
1602 if (fwrite(s, 1, len, pt->rep.stdio.file) == 0)
1605 for (; len; len--) {
1606 if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1607 *pt->rep.string.curr++ = *s++;
1614 putcharacter(scheme* sc,
int c) {
1615 port* pt = sc->outport->_object._port;
1616 if (pt->kind & port_file) {
1617 fputc(c, pt->rep.stdio.file);
1619 if (pt->rep.string.curr != pt->rep.string.past_the_end) {
1620 *pt->rep.string.curr++ = c;
1627 readstr_upto(scheme* sc,
char* delim) {
1628 char* p = sc->strbuff;
1630 while (!is_one_of(delim, (*p++ = inchar(sc))))
1632 if (p == sc->strbuff + 2 && p[-2] ==
'\\') {
1635 backchar(sc, p[-1]);
1643 readstrexp(scheme* sc) {
1644 char* p = sc->strbuff;
1657 if (c == EOF || p - sc->strbuff >
sizeof(sc->strbuff) - 1) {
1663 case '\\': state = st_bsl;
break;
1664 case '"': *p = 0;
return mk_counted_string(sc, sc->strbuff, p - sc->strbuff);
1665 default: *p++ = c;
break;
1700 if (c >=
'0' && c <=
'F') {
1702 c1 = (c1 << 4) + c -
'0';
1704 c1 = (c1 << 4) + c -
'A' + 10;
1706 if (state == st_x1) {
1722 is_one_of(
char* s,
int c) {
1733 skipspace(scheme* sc) {
1735 while (isspace(c = inchar(sc)))
1747 switch (c = inchar(sc)) {
1748 case EOF:
return (TOK_EOF);
1749 case '(':
return (TOK_LPAREN);
1750 case ')':
return (TOK_RPAREN);
1753 if (is_one_of(
" \n\t", c)) {
1760 case '\'':
return (TOK_QUOTE);
1761 case ';':
return (TOK_COMMENT);
1762 case '"':
return (TOK_DQUOTE);
1763 case BACKQUOTE:
return (TOK_BQUOTE);
1765 if ((c = inchar(sc)) ==
'@')
1766 return (TOK_ATMARK);
1775 }
else if (c ==
'!') {
1779 if (is_one_of(
" tfodxb\\", c)) {
1780 return TOK_SHARP_CONST;
1785 default: backchar(sc, c);
return (TOK_ATOM);
1790 #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
1793 printslashstring(scheme* sc,
char* p,
int len) {
1795 unsigned char* s = (
unsigned char*)p;
1796 putcharacter(sc,
'"');
1797 for (i = 0; i < len; i++) {
1798 if (*s == 0xff || *s ==
'"' || *s <
' ' || *s ==
'\\') {
1799 putcharacter(sc,
'\\');
1801 case '"': putcharacter(sc,
'"');
break;
1802 case '\n': putcharacter(sc,
'n');
break;
1803 case '\t': putcharacter(sc,
't');
break;
1804 case '\r': putcharacter(sc,
'r');
break;
1805 case '\\': putcharacter(sc,
'\\');
break;
1809 putcharacter(sc,
'x');
1811 putcharacter(sc, d +
'0');
1813 putcharacter(sc, d - 10 +
'A');
1817 putcharacter(sc, d +
'0');
1819 putcharacter(sc, d - 10 +
'A');
1824 putcharacter(sc, *s);
1828 putcharacter(sc,
'"');
1833 printatom(scheme* sc, pointer l,
int f) {
1836 atom2str(sc, l, f, &p, &len);
1837 putchars(sc, p, len);
1842 atom2str(scheme* sc, pointer l,
int f,
char** pp,
int* plen) {
1847 }
else if (l == sc->T) {
1849 }
else if (l == sc->F) {
1851 }
else if (l == sc->EOF_OBJ) {
1853 }
else if (is_port(l)) {
1855 strcpy(p,
"#<PORT>");
1856 }
else if (is_number(l)) {
1858 if (is_integer(l)) {
1859 sprintf(p,
"%ld", ivalue_unchecked(l));
1861 sprintf(p,
"%.10g", rvalue_unchecked(l));
1863 }
else if (is_string(l)) {
1869 printslashstring(sc, strvalue(l), strlength(l));
1872 }
else if (is_character(l)) {
1873 int c = charvalue(l);
1880 case ' ': sprintf(p,
"#\\space");
break;
1881 case '\n': sprintf(p,
"#\\newline");
break;
1882 case '\r': sprintf(p,
"#\\return");
break;
1883 case '\t': sprintf(p,
"#\\tab");
break;
1887 strcpy(p,
"#\\del");
1889 }
else if (c < 32) {
1891 strcat(p, charnames[c]);
1896 sprintf(p,
"#\\x%x", c);
1900 sprintf(p,
"#\\%c", c);
1904 }
else if (is_symbol(l)) {
1906 }
else if (is_proc(l)) {
1908 sprintf(p,
"#<%s PROCEDURE %ld>", procname(l), procnum(l));
1909 }
else if (is_macro(l)) {
1911 }
else if (is_closure(l)) {
1913 }
else if (is_promise(l)) {
1915 }
else if (is_foreign(l)) {
1917 sprintf(p,
"#<FOREIGN PROCEDURE %ld>", procnum(l));
1918 }
else if (is_continuation(l)) {
1919 p =
"#<CONTINUATION>";
1931 mk_closure(scheme* sc, pointer c, pointer e) {
1932 pointer x = get_cell(sc, c, e);
1934 typeflag(x) = T_CLOSURE;
1942 mk_continuation(scheme* sc, pointer d) {
1943 pointer x = get_cell(sc, sc->NIL, d);
1945 typeflag(x) = T_CONTINUATION;
1951 list_star(scheme* sc, pointer d) {
1953 if (cdr(d) == sc->NIL) {
1956 p = cons(sc, car(d), cdr(d));
1958 while (cdr(cdr(p)) != sc->NIL) {
1959 d = cons(sc, car(p), cdr(p));
1960 if (cdr(cdr(p)) != sc->NIL) {
1964 cdr(p) = car(cdr(p));
1970 reverse(scheme* sc, pointer a) {
1972 pointer p = sc->NIL;
1974 for (; is_pair(a); a = cdr(a)) {
1975 p = cons(sc, car(a), p);
1982 reverse_in_place(scheme* sc, pointer term, pointer list) {
1983 pointer p = list, result = term, q;
1985 while (p != sc->NIL) {
1996 append(scheme* sc, pointer a, pointer b) {
2001 while (a != sc->NIL) {
2013 eqv(pointer a, pointer b) {
2016 return (strvalue(a) == strvalue(b));
2019 }
else if (is_number(a)) {
2021 return num_eq(nvalue(a), nvalue(b));
2024 }
else if (is_character(a)) {
2025 if (is_character(b))
2026 return charvalue(a) == charvalue(b);
2029 }
else if (is_port(a)) {
2034 }
else if (is_proc(a)) {
2036 return procnum(a) == procnum(b);
2046 #define is_true(p) ((p) != sc->F)
2047 #define is_false(p) ((p) == sc->F)
2051 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2054 hash_fn(
const char* key,
int table_size) {
2055 unsigned int hashed = 0;
2057 int bits_per_int =
sizeof(
unsigned int) * 8;
2059 for (c = key; *c; c++) {
2061 hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
2064 return hashed % table_size;
2068 #ifndef USE_ALIST_ENV
2079 new_frame_in_env(scheme* sc, pointer old_env) {
2083 if (old_env == sc->NIL) {
2084 new_frame = mk_vector(sc, 461);
2086 new_frame = sc->NIL;
2089 sc->envir = immutable_cons(sc, new_frame, old_env);
2090 setenvironment(sc->envir);
2094 new_slot_spec_in_env(scheme* sc, pointer env, pointer variable, pointer value) {
2095 pointer slot = immutable_cons(sc, variable, value);
2097 if (is_vector(car(env))) {
2098 int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2100 set_vector_elem(car(env), location, immutable_cons(sc, slot, vector_elem(car(env), location)));
2102 car(env) = immutable_cons(sc, slot, car(env));
2107 find_slot_in_env(scheme* sc, pointer env, pointer hdl,
int all) {
2108 pointer x = sc->NIL, y = sc->NIL;
2111 for (x = env; x != sc->NIL; x = cdr(x)) {
2112 if (is_vector(car(x))) {
2113 location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2114 y = vector_elem(car(x), location);
2118 for (; y != sc->NIL; y = cdr(y)) {
2119 if (caar(y) == hdl) {
2139 new_frame_in_env(scheme* sc, pointer old_env) {
2140 sc->envir = immutable_cons(sc, sc->NIL, old_env);
2141 setenvironment(sc->envir);
2145 new_slot_spec_in_env(scheme* sc, pointer env, pointer variable, pointer value) {
2146 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2150 find_slot_in_env(scheme* sc, pointer env, pointer hdl,
int all) {
2152 for (x = env; x != sc->NIL; x = cdr(x)) {
2153 for (y = car(x); y != sc->NIL; y = cdr(y)) {
2154 if (caar(y) == hdl) {
2174 new_slot_in_env(scheme* sc, pointer variable, pointer value) {
2175 new_slot_spec_in_env(sc, sc->envir, variable, value);
2179 set_slot_in_env(scheme* sc, pointer slot, pointer value) {
2183 static INLINE pointer
2184 slot_value_in_env(pointer slot) {
2191 _Error_1(scheme* sc,
const char* s, pointer a) {
2194 pointer hdl = sc->ERROR_HOOK;
2196 x = find_slot_in_env(sc, sc->envir, hdl, 1);
2199 sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, (a), sc->NIL)), sc->NIL);
2203 sc->code = cons(sc, mk_string(sc, (s)), sc->code);
2204 setimmutable(car(sc->code));
2205 sc->code = cons(sc, slot_value_in_env(x), sc->code);
2206 sc->op = (int)OP_EVAL;
2212 sc->args = cons(sc, (a), sc->NIL);
2216 sc->args = cons(sc, mk_string(sc, (s)), sc->args);
2217 setimmutable(car(sc->args));
2218 sc->op = (int)OP_ERR0;
2222 #define Error_1(sc, s, a) return _Error_1(sc, s, a)
2223 #define Error_0(sc, s) return _Error_1(sc, s, 0)
2230 #define s_goto(sc, a) \
2232 sc->op = (int)(a); \
2236 #define s_return(sc, a) return _s_return(sc, a)
2238 #ifndef USE_SCHEME_STACK
2241 struct dump_stack_frame {
2242 enum scheme_opcodes op;
2248 #define STACK_GROWTH 3
2251 s_save(scheme* sc,
enum scheme_opcodes op, pointer args, pointer code) {
2252 long nframes = (long)sc->dump;
2253 struct dump_stack_frame* next_frame;
2256 if (nframes >= sc->dump_size) {
2257 sc->dump_size += STACK_GROWTH;
2259 sc->dump_base = realloc(sc->dump_base,
sizeof(
struct dump_stack_frame) * sc->dump_size);
2261 next_frame = (
struct dump_stack_frame*)sc->dump_base + nframes;
2262 next_frame->op = op;
2263 next_frame->args = args;
2264 next_frame->envir = sc->envir;
2265 next_frame->code = code;
2266 sc->dump = (pointer)(nframes + 1L);
2270 _s_return(scheme* sc, pointer a) {
2271 long nframes = (long)sc->dump;
2272 struct dump_stack_frame* frame;
2279 frame = (
struct dump_stack_frame*)sc->dump_base + nframes;
2281 sc->args = frame->args;
2282 sc->envir = frame->envir;
2283 sc->code = frame->code;
2284 sc->dump = (pointer)nframes;
2289 dump_stack_reset(scheme* sc) {
2291 sc->dump = (pointer)0;
2295 dump_stack_initialize(scheme* sc) {
2297 sc->dump_base = NULL;
2298 dump_stack_reset(sc);
2302 dump_stack_free(scheme* sc) {
2303 free(sc->dump_base);
2304 sc->dump_base = NULL;
2305 sc->dump = (pointer)0;
2310 dump_stack_mark(scheme* sc) {
2311 long nframes = (long)sc->dump;
2313 for (i = 0; i < nframes; i++) {
2314 struct dump_stack_frame* frame;
2315 frame = (
struct dump_stack_frame*)sc->dump_base + i;
2325 dump_stack_reset(scheme* sc) {
2330 dump_stack_initialize(scheme* sc) {
2331 dump_stack_reset(sc);
2335 dump_stack_free(scheme* sc) {
2340 _s_return(scheme* sc, pointer a) {
2342 if (sc->dump == sc->NIL)
2344 sc->op = ivalue(car(sc->dump));
2345 sc->args = cadr(sc->dump);
2346 sc->envir = caddr(sc->dump);
2347 sc->code = cadddr(sc->dump);
2348 sc->dump = cddddr(sc->dump);
2353 s_save(scheme* sc,
enum scheme_opcodes op, pointer args, pointer code) {
2354 sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2355 sc->dump = cons(sc, (args), sc->dump);
2356 sc->dump = cons(sc, mk_integer(sc, (
long)(op)), sc->dump);
2360 dump_stack_mark(scheme* sc) {
2365 #define s_retbool(tf) s_return(sc, (tf) ? sc->T : sc->F)
2368 opexe_0(scheme* sc,
enum scheme_opcodes op) {
2373 if (file_interactive(sc)) {
2374 fprintf(sc->outport->_object._port->rep.stdio.file,
"Loading %s\n", strvalue(car(sc->args)));
2376 if (!file_push(sc, strvalue(car(sc->args)))) {
2377 Error_1(sc,
"unable to open", car(sc->args));
2379 s_goto(sc, OP_T0LVL);
2382 if (file_interactive(sc)) {
2386 dump_stack_reset(sc);
2387 sc->envir = sc->global_env;
2388 sc->save_inport = sc->inport;
2389 sc->inport = sc->loadport;
2390 s_save(sc, OP_T0LVL, sc->NIL, sc->NIL);
2391 s_save(sc, OP_VALUEPRINT, sc->NIL, sc->NIL);
2392 s_save(sc, OP_T1LVL, sc->NIL, sc->NIL);
2393 if (file_interactive(sc)) {
2396 s_goto(sc, OP_READ_INTERNAL);
2399 sc->code = sc->value;
2400 sc->inport = sc->save_inport;
2401 s_goto(sc, OP_EVAL);
2403 case OP_READ_INTERNAL:
2404 sc->tok = token(sc);
2405 if (sc->tok == TOK_EOF) {
2406 if (sc->inport == sc->loadport) {
2408 s_goto(sc, OP_QUIT);
2410 s_return(sc, sc->EOF_OBJ);
2413 s_goto(sc, OP_RDSEXPR);
2415 case OP_GENSYM: s_return(sc, gensym(sc));
2422 putstr(sc,
"\nGives: ");
2424 if (file_interactive(sc)) {
2426 sc->args = sc->value;
2427 s_goto(sc, OP_P0LIST);
2429 s_return(sc, sc->value);
2436 s_save(sc, OP_REAL_EVAL, sc->args, sc->code);
2437 sc->args = sc->code;
2438 putstr(sc,
"\nEval: ");
2439 s_goto(sc, OP_P0LIST);
2444 if (is_symbol(sc->code)) {
2445 x = find_slot_in_env(sc, sc->envir, sc->code, 1);
2447 s_return(sc, slot_value_in_env(x));
2449 Error_1(sc,
"eval: unbound variable:", sc->code);
2451 }
else if (is_pair(sc->code)) {
2452 if (is_syntax(x = car(sc->code))) {
2453 sc->code = cdr(sc->code);
2454 s_goto(sc, syntaxnum(x));
2456 s_save(sc, OP_E0ARGS, sc->NIL, sc->code);
2458 sc->code = car(sc->code);
2459 s_goto(sc, OP_EVAL);
2462 s_return(sc, sc->code);
2466 if (is_macro(sc->value)) {
2467 s_save(sc, OP_DOMACRO, sc->NIL, sc->NIL);
2468 sc->args = cons(sc, sc->code, sc->NIL);
2469 sc->code = sc->value;
2470 s_goto(sc, OP_APPLY);
2472 sc->code = cdr(sc->code);
2473 s_goto(sc, OP_E1ARGS);
2477 sc->args = cons(sc, sc->value, sc->args);
2478 if (is_pair(sc->code)) {
2479 s_save(sc, OP_E1ARGS, sc->args, cdr(sc->code));
2480 sc->code = car(sc->code);
2482 s_goto(sc, OP_EVAL);
2484 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2485 sc->code = car(sc->args);
2486 sc->args = cdr(sc->args);
2487 s_goto(sc, OP_APPLY);
2493 int tr = sc->tracing;
2494 sc->tracing = ivalue(car(sc->args));
2495 s_return(sc, mk_integer(sc, tr));
2502 s_save(sc, OP_REAL_APPLY, sc->args, sc->code);
2505 putstr(sc,
"\nApply to: ");
2506 s_goto(sc, OP_P0LIST);
2511 if (is_proc(sc->code)) {
2512 s_goto(sc, procnum(sc->code));
2513 }
else if (is_foreign(sc->code)) {
2514 x = sc->code->_object._ff(sc, sc->args);
2516 }
else if (is_closure(sc->code) || is_macro(sc->code) || is_promise(sc->code)) {
2519 new_frame_in_env(sc, closure_env(sc->code));
2520 for (x = car(closure_code(sc->code)), y = sc->args; is_pair(x); x = cdr(x), y = cdr(y)) {
2522 Error_0(sc,
"not enough arguments");
2524 new_slot_in_env(sc, car(x), car(y));
2533 }
else if (is_symbol(x))
2534 new_slot_in_env(sc, x, y);
2536 Error_1(sc,
"syntax error in closure: not a symbol:", x);
2538 sc->code = cdr(closure_code(sc->code));
2540 s_goto(sc, OP_BEGIN);
2541 }
else if (is_continuation(sc->code)) {
2542 sc->dump = cont_dump(sc->code);
2543 s_return(sc, sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2545 Error_0(sc,
"illegal function");
2548 case OP_DOMACRO: sc->code = sc->value; s_goto(sc, OP_EVAL);
2550 case OP_LAMBDA: s_return(sc, mk_closure(sc, sc->code, sc->envir));
2554 if (car(x) == sc->LAMBDA) {
2557 if (cdr(sc->args) == sc->NIL) {
2562 s_return(sc, mk_closure(sc, x, y));
2564 case OP_QUOTE: x = car(sc->code); s_return(sc, car(sc->code));
2567 if (is_pair(car(sc->code))) {
2569 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2572 sc->code = cadr(sc->code);
2574 if (!is_symbol(x)) {
2575 Error_0(sc,
"variable is not a symbol");
2577 s_save(sc, OP_DEF1, sc->NIL, x);
2578 s_goto(sc, OP_EVAL);
2581 x = find_slot_in_env(sc, sc->envir, sc->code, 0);
2583 set_slot_in_env(sc, x, sc->value);
2585 new_slot_in_env(sc, sc->code, sc->value);
2587 s_return(sc, sc->code);
2591 if (cdr(sc->args) != sc->NIL) {
2594 s_retbool(find_slot_in_env(sc, x, car(sc->args), 1) != sc->NIL);
2597 s_save(sc, OP_SET1, sc->NIL, car(sc->code));
2598 sc->code = cadr(sc->code);
2599 s_goto(sc, OP_EVAL);
2602 y = find_slot_in_env(sc, sc->envir, sc->code, 1);
2604 set_slot_in_env(sc, y, sc->value);
2605 s_return(sc, sc->value);
2607 Error_1(sc,
"set!: unbound variable:", sc->code);
2611 if (!is_pair(sc->code)) {
2612 s_return(sc, sc->code);
2614 if (cdr(sc->code) != sc->NIL) {
2615 s_save(sc, OP_BEGIN, sc->NIL, cdr(sc->code));
2617 sc->code = car(sc->code);
2618 s_goto(sc, OP_EVAL);
2621 s_save(sc, OP_IF1, sc->NIL, cdr(sc->code));
2622 sc->code = car(sc->code);
2623 s_goto(sc, OP_EVAL);
2626 if (is_true(sc->value))
2627 sc->code = car(sc->code);
2629 sc->code = cadr(sc->code);
2631 s_goto(sc, OP_EVAL);
2635 sc->value = sc->code;
2636 sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2637 s_goto(sc, OP_LET1);
2640 sc->args = cons(sc, sc->value, sc->args);
2641 if (is_pair(sc->code)) {
2642 s_save(sc, OP_LET1, sc->args, cdr(sc->code));
2643 sc->code = cadar(sc->code);
2645 s_goto(sc, OP_EVAL);
2647 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2648 sc->code = car(sc->args);
2649 sc->args = cdr(sc->args);
2650 s_goto(sc, OP_LET2);
2654 new_frame_in_env(sc, sc->envir);
2655 for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; y != sc->NIL;
2656 x = cdr(x), y = cdr(y)) {
2657 new_slot_in_env(sc, caar(x), car(y));
2659 if (is_symbol(car(sc->code))) {
2660 for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2662 sc->args = cons(sc, caar(x), sc->args);
2664 x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2665 new_slot_in_env(sc, car(sc->code), x);
2666 sc->code = cddr(sc->code);
2669 sc->code = cdr(sc->code);
2672 s_goto(sc, OP_BEGIN);
2675 if (car(sc->code) == sc->NIL) {
2676 new_frame_in_env(sc, sc->envir);
2677 sc->code = cdr(sc->code);
2678 s_goto(sc, OP_BEGIN);
2680 s_save(sc, OP_LET1AST, cdr(sc->code), car(sc->code));
2681 sc->code = cadaar(sc->code);
2682 s_goto(sc, OP_EVAL);
2684 case OP_LET1AST: new_frame_in_env(sc, sc->envir); s_goto(sc, OP_LET2AST);
2687 new_slot_in_env(sc, caar(sc->code), sc->value);
2688 sc->code = cdr(sc->code);
2689 if (is_pair(sc->code)) {
2690 s_save(sc, OP_LET2AST, sc->args, sc->code);
2691 sc->code = cadar(sc->code);
2693 s_goto(sc, OP_EVAL);
2695 sc->code = sc->args;
2697 s_goto(sc, OP_BEGIN);
2699 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
2705 opexe_1(scheme* sc,
enum scheme_opcodes op) {
2710 new_frame_in_env(sc, sc->envir);
2712 sc->value = sc->code;
2713 sc->code = car(sc->code);
2714 s_goto(sc, OP_LET1REC);
2717 sc->args = cons(sc, sc->value, sc->args);
2718 if (is_pair(sc->code)) {
2719 s_save(sc, OP_LET1REC, sc->args, cdr(sc->code));
2720 sc->code = cadar(sc->code);
2722 s_goto(sc, OP_EVAL);
2724 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2725 sc->code = car(sc->args);
2726 sc->args = cdr(sc->args);
2727 s_goto(sc, OP_LET2REC);
2731 for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2732 new_slot_in_env(sc, caar(x), car(y));
2734 sc->code = cdr(sc->code);
2736 s_goto(sc, OP_BEGIN);
2739 if (!is_pair(sc->code)) {
2740 Error_0(sc,
"syntax error in cond");
2742 s_save(sc, OP_COND1, sc->NIL, sc->code);
2743 sc->code = caar(sc->code);
2744 s_goto(sc, OP_EVAL);
2747 if (is_true(sc->value)) {
2748 if ((sc->code = cdar(sc->code)) == sc->NIL) {
2749 s_return(sc, sc->value);
2751 if (car(sc->code) == sc->FEED_TO) {
2752 if (!is_pair(cdr(sc->code))) {
2753 Error_0(sc,
"syntax error in cond");
2755 x = cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2756 sc->code = cons(sc, cadr(sc->code), cons(sc, x, sc->NIL));
2757 s_goto(sc, OP_EVAL);
2759 s_goto(sc, OP_BEGIN);
2761 if ((sc->code = cdr(sc->code)) == sc->NIL) {
2762 s_return(sc, sc->NIL);
2764 s_save(sc, OP_COND1, sc->NIL, sc->code);
2765 sc->code = caar(sc->code);
2766 s_goto(sc, OP_EVAL);
2771 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2772 typeflag(x) = T_PROMISE;
2776 if (sc->code == sc->NIL) {
2777 s_return(sc, sc->T);
2779 s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
2780 sc->code = car(sc->code);
2781 s_goto(sc, OP_EVAL);
2784 if (is_false(sc->value)) {
2785 s_return(sc, sc->value);
2786 }
else if (sc->code == sc->NIL) {
2787 s_return(sc, sc->value);
2789 s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
2790 sc->code = car(sc->code);
2791 s_goto(sc, OP_EVAL);
2795 if (sc->code == sc->NIL) {
2796 s_return(sc, sc->F);
2798 s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
2799 sc->code = car(sc->code);
2800 s_goto(sc, OP_EVAL);
2803 if (is_true(sc->value)) {
2804 s_return(sc, sc->value);
2805 }
else if (sc->code == sc->NIL) {
2806 s_return(sc, sc->value);
2808 s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
2809 sc->code = car(sc->code);
2810 s_goto(sc, OP_EVAL);
2814 s_save(sc, OP_C1STREAM, sc->NIL, cdr(sc->code));
2815 sc->code = car(sc->code);
2816 s_goto(sc, OP_EVAL);
2819 sc->args = sc->value;
2820 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2821 typeflag(x) = T_PROMISE;
2822 s_return(sc, cons(sc, sc->args, x));
2825 if (is_pair(car(sc->code))) {
2827 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2830 sc->code = cadr(sc->code);
2832 if (!is_symbol(x)) {
2833 Error_0(sc,
"variable is not a symbol");
2835 s_save(sc, OP_MACRO1, sc->NIL, x);
2836 s_goto(sc, OP_EVAL);
2839 typeflag(sc->value) = T_MACRO;
2840 x = find_slot_in_env(sc, sc->envir, sc->code, 0);
2842 set_slot_in_env(sc, x, sc->value);
2844 new_slot_in_env(sc, sc->code, sc->value);
2846 s_return(sc, sc->code);
2849 s_save(sc, OP_CASE1, sc->NIL, cdr(sc->code));
2850 sc->code = car(sc->code);
2851 s_goto(sc, OP_EVAL);
2854 for (x = sc->code; x != sc->NIL; x = cdr(x)) {
2855 if (!is_pair(y = caar(x))) {
2858 for (; y != sc->NIL; y = cdr(y)) {
2859 if (eqv(car(y), sc->value)) {
2868 if (is_pair(caar(x))) {
2870 s_goto(sc, OP_BEGIN);
2872 s_save(sc, OP_CASE2, sc->NIL, cdar(x));
2874 s_goto(sc, OP_EVAL);
2877 s_return(sc, sc->NIL);
2881 if (is_true(sc->value)) {
2882 s_goto(sc, OP_BEGIN);
2884 s_return(sc, sc->NIL);
2888 sc->code = car(sc->args);
2889 sc->args = list_star(sc, cdr(sc->args));
2891 s_goto(sc, OP_APPLY);
2894 if (cdr(sc->args) != sc->NIL) {
2895 sc->envir = cadr(sc->args);
2897 sc->code = car(sc->args);
2898 s_goto(sc, OP_EVAL);
2900 case OP_CONTINUATION:
2901 sc->code = car(sc->args);
2902 sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
2903 s_goto(sc, OP_APPLY);
2905 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
2911 opexe_2(scheme* sc,
enum scheme_opcodes op) {
2922 if (is_integer(x)) {
2924 }
else if (modf(rvalue_unchecked(x), &dd) == 0.0) {
2925 s_return(sc, mk_integer(sc, ivalue(x)));
2927 Error_1(sc,
"inexact->exact: not integral:", x);
2930 case OP_EXP: x = car(sc->args); s_return(sc, mk_real(sc, exp(rvalue(x))));
2932 case OP_LOG: x = car(sc->args); s_return(sc, mk_real(sc, log(rvalue(x))));
2934 case OP_SIN: x = car(sc->args); s_return(sc, mk_real(sc, sin(rvalue(x))));
2936 case OP_COS: x = car(sc->args); s_return(sc, mk_real(sc, cos(rvalue(x))));
2938 case OP_TAN: x = car(sc->args); s_return(sc, mk_real(sc, tan(rvalue(x))));
2940 case OP_ASIN: x = car(sc->args); s_return(sc, mk_real(sc, asin(rvalue(x))));
2942 case OP_ACOS: x = car(sc->args); s_return(sc, mk_real(sc, acos(rvalue(x))));
2946 if (cdr(sc->args) == sc->NIL) {
2947 s_return(sc, mk_real(sc, atan(rvalue(x))));
2949 pointer y = cadr(sc->args);
2950 s_return(sc, mk_real(sc, atan2(rvalue(x), rvalue(y))));
2953 case OP_SQRT: x = car(sc->args); s_return(sc, mk_real(sc, sqrt(rvalue(x))));
2957 if (cdr(sc->args) == sc->NIL) {
2958 Error_0(sc,
"expt: needs two arguments");
2960 pointer y = cadr(sc->args);
2961 s_return(sc, mk_real(sc, pow(rvalue(x), rvalue(y))));
2964 case OP_FLOOR: x = car(sc->args); s_return(sc, mk_real(sc, floor(rvalue(x))));
2966 case OP_CEILING: x = car(sc->args); s_return(sc, mk_real(sc, ceil(rvalue(x))));
2972 rvalue_of_x = rvalue(x);
2973 if (rvalue_of_x > 0) {
2974 s_return(sc, mk_real(sc, floor(rvalue_of_x)));
2976 s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
2980 case OP_ROUND: x = car(sc->args); s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
2985 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
2986 v = num_add(v, nvalue(car(x)));
2988 s_return(sc, mk_number(sc, v));
2992 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
2993 v = num_mul(v, nvalue(car(x)));
2995 s_return(sc, mk_number(sc, v));
2998 if (cdr(sc->args) == sc->NIL) {
3003 v = nvalue(car(sc->args));
3005 for (; x != sc->NIL; x = cdr(x)) {
3006 v = num_sub(v, nvalue(car(x)));
3008 s_return(sc, mk_number(sc, v));
3011 if (cdr(sc->args) == sc->NIL) {
3016 v = nvalue(car(sc->args));
3018 for (; x != sc->NIL; x = cdr(x)) {
3019 if (!is_zero_double(rvalue(car(x))))
3020 v = num_div(v, nvalue(car(x)));
3022 Error_0(sc,
"/: division by zero");
3025 s_return(sc, mk_number(sc, v));
3028 if (cdr(sc->args) == sc->NIL) {
3033 v = nvalue(car(sc->args));
3035 for (; x != sc->NIL; x = cdr(x)) {
3036 if (ivalue(car(x)) != 0)
3037 v = num_intdiv(v, nvalue(car(x)));
3039 Error_0(sc,
"quotient: division by zero");
3042 s_return(sc, mk_number(sc, v));
3045 v = nvalue(car(sc->args));
3046 if (ivalue(cadr(sc->args)) != 0)
3047 v = num_rem(v, nvalue(cadr(sc->args)));
3049 Error_0(sc,
"remainder: division by zero");
3051 s_return(sc, mk_number(sc, v));
3054 v = nvalue(car(sc->args));
3055 if (ivalue(cadr(sc->args)) != 0)
3056 v = num_mod(v, nvalue(cadr(sc->args)));
3058 Error_0(sc,
"modulo: division by zero");
3060 s_return(sc, mk_number(sc, v));
3062 case OP_CAR: s_return(sc, caar(sc->args));
3064 case OP_CDR: s_return(sc, cdar(sc->args));
3066 case OP_CONS: cdr(sc->args) = cadr(sc->args); s_return(sc, sc->args);
3069 if (!is_immutable(car(sc->args))) {
3070 caar(sc->args) = cadr(sc->args);
3071 s_return(sc, car(sc->args));
3073 Error_0(sc,
"set-car!: unable to alter immutable pair");
3077 if (!is_immutable(car(sc->args))) {
3078 cdar(sc->args) = cadr(sc->args);
3079 s_return(sc, car(sc->args));
3081 Error_0(sc,
"set-cdr!: unable to alter immutable pair");
3087 c = (char)ivalue(car(sc->args));
3088 s_return(sc, mk_integer(sc, (
unsigned char)c));
3094 c = (
unsigned char)ivalue(car(sc->args));
3095 s_return(sc, mk_character(sc, (
char)c));
3101 c = (
unsigned char)ivalue(car(sc->args));
3103 s_return(sc, mk_character(sc, (
char)c));
3109 c = (
unsigned char)ivalue(car(sc->args));
3111 s_return(sc, mk_character(sc, (
char)c));
3114 case OP_STR2SYM: s_return(sc, mk_symbol(sc, strvalue(car(sc->args))));
3118 char* s = strvalue(car(sc->args));
3120 s_return(sc, mk_sharp_const(sc, s + 1));
3122 s_return(sc, mk_atom(sc, s));
3127 x = mk_string(sc, symname(car(sc->args)));
3132 if (is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3135 atom2str(sc, x, 0, &p, &len);
3136 s_return(sc, mk_counted_string(sc, p, len));
3138 Error_1(sc,
"atom->string: not an atom:", x);
3146 len = ivalue(car(sc->args));
3148 if (cdr(sc->args) != sc->NIL) {
3149 fill = charvalue(cadr(sc->args));
3151 s_return(sc, mk_empty_string(sc, len, (
char)fill));
3154 case OP_STRLEN: s_return(sc, mk_integer(sc, strlength(car(sc->args))));
3161 str = strvalue(car(sc->args));
3163 index = ivalue(cadr(sc->args));
3165 if (index >= strlength(car(sc->args))) {
3166 Error_1(sc,
"string-ref: out of bounds:", cadr(sc->args));
3169 s_return(sc, mk_character(sc, ((
unsigned char*)str)[index]));
3178 if (is_immutable(car(sc->args))) {
3179 Error_1(sc,
"string-set!: unable to alter immutable string:", car(sc->args));
3181 str = strvalue(car(sc->args));
3183 index = ivalue(cadr(sc->args));
3184 if (index >= strlength(car(sc->args))) {
3185 Error_1(sc,
"string-set!: out of bounds:", cadr(sc->args));
3188 c = charvalue(caddr(sc->args));
3190 str[index] = (char)c;
3191 s_return(sc, car(sc->args));
3202 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3203 len += strlength(car(x));
3205 newstr = mk_empty_string(sc, len,
' ');
3207 for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; pos += strlength(car(x)), x = cdr(x)) {
3208 memcpy(pos, strvalue(car(x)), strlength(car(x)));
3210 s_return(sc, newstr);
3220 str = strvalue(car(sc->args));
3222 index0 = ivalue(cadr(sc->args));
3224 if (index0 > strlength(car(sc->args))) {
3225 Error_1(sc,
"substring: start out of bounds:", cadr(sc->args));
3228 if (cddr(sc->args) != sc->NIL) {
3229 index1 = ivalue(caddr(sc->args));
3230 if (index1 > strlength(car(sc->args)) || index1 < index0) {
3231 Error_1(sc,
"substring: end out of bounds:", caddr(sc->args));
3234 index1 = strlength(car(sc->args));
3237 len = index1 - index0;
3238 x = mk_empty_string(sc, len,
' ');
3239 memcpy(strvalue(x), str + index0, len);
3240 strvalue(x)[len] = 0;
3249 int len = list_length(sc, sc->args);
3251 Error_1(sc,
"vector: not a proper list:", sc->args);
3253 vec = mk_vector(sc, len);
3254 for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3255 set_vector_elem(vec, i, car(x));
3262 pointer fill = sc->NIL;
3266 len = ivalue(car(sc->args));
3268 if (cdr(sc->args) != sc->NIL) {
3269 fill = cadr(sc->args);
3271 vec = mk_vector(sc, len);
3272 if (fill != sc->NIL) {
3273 fill_vector(vec, fill);
3278 case OP_VECLEN: s_return(sc, mk_integer(sc, ivalue(car(sc->args))));
3284 index = ivalue(cadr(sc->args));
3286 if (index >= ivalue(car(sc->args))) {
3287 Error_1(sc,
"vector-ref: out of bounds:", cadr(sc->args));
3290 s_return(sc, vector_elem(car(sc->args), index));
3297 if (is_immutable(car(sc->args))) {
3298 Error_1(sc,
"vector-set!: unable to alter immutable vector:", car(sc->args));
3301 index = ivalue(cadr(sc->args));
3302 if (index >= ivalue(car(sc->args))) {
3303 Error_1(sc,
"vector-set!: out of bounds:", cadr(sc->args));
3306 set_vector_elem(car(sc->args), index, caddr(sc->args));
3307 s_return(sc, car(sc->args));
3310 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3316 list_length(scheme* sc, pointer a) {
3319 for (x = a, v = 0; is_pair(x); x = cdr(x)) {
3329 opexe_3(scheme* sc,
enum scheme_opcodes op) {
3332 int (*comp_func)(num, num) = 0;
3335 case OP_NOT: s_retbool(is_false(car(sc->args)));
3336 case OP_BOOLP: s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3337 case OP_EOFOBJP: s_retbool(car(sc->args) == sc->EOF_OBJ);
3338 case OP_NULLP: s_retbool(car(sc->args) == sc->NIL);
3345 case OP_NUMEQ: comp_func = num_eq;
break;
3346 case OP_LESS: comp_func = num_lt;
break;
3347 case OP_GRE: comp_func = num_gt;
break;
3348 case OP_LEQ: comp_func = num_le;
break;
3349 case OP_GEQ: comp_func = num_ge;
break;
3356 for (; x != sc->NIL; x = cdr(x)) {
3357 if (!comp_func(v, nvalue(car(x)))) {
3363 case OP_SYMBOLP: s_retbool(is_symbol(car(sc->args)));
3364 case OP_NUMBERP: s_retbool(is_number(car(sc->args)));
3365 case OP_STRINGP: s_retbool(is_string(car(sc->args)));
3366 case OP_INTEGERP: s_retbool(is_integer(car(sc->args)));
3367 case OP_REALP: s_retbool(is_number(car(sc->args)));
3368 case OP_CHARP: s_retbool(is_character(car(sc->args)));
3369 #if USE_CHAR_CLASSIFIERS
3370 case OP_CHARAP: s_retbool(Cisalpha(ivalue(car(sc->args))));
3371 case OP_CHARNP: s_retbool(Cisdigit(ivalue(car(sc->args))));
3372 case OP_CHARWP: s_retbool(Cisspace(ivalue(car(sc->args))));
3373 case OP_CHARUP: s_retbool(Cisupper(ivalue(car(sc->args))));
3374 case OP_CHARLP: s_retbool(Cislower(ivalue(car(sc->args))));
3376 case OP_PORTP: s_retbool(is_port(car(sc->args)));
3377 case OP_INPORTP: s_retbool(is_inport(car(sc->args)));
3378 case OP_OUTPORTP: s_retbool(is_outport(car(sc->args)));
3386 is_proc(car(sc->args)) || is_closure(car(sc->args)) || is_continuation(car(sc->args))
3387 || is_foreign(car(sc->args))
3389 case OP_PAIRP: s_retbool(is_pair(car(sc->args)));
3393 slow = fast = car(sc->args);
3396 s_retbool(fast == sc->NIL);
3399 s_retbool(fast == sc->NIL);
3410 case OP_ENVP: s_retbool(is_environment(car(sc->args)));
3411 case OP_VECTORP: s_retbool(is_vector(car(sc->args)));
3412 case OP_EQ: s_retbool(car(sc->args) == cadr(sc->args));
3413 case OP_EQV: s_retbool(eqv(car(sc->args), cadr(sc->args)));
3414 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3420 opexe_4(scheme* sc,
enum scheme_opcodes op) {
3425 sc->code = car(sc->args);
3426 if (is_promise(sc->code)) {
3428 s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3430 s_goto(sc, OP_APPLY);
3432 s_return(sc, sc->code);
3435 case OP_SAVE_FORCED:
3436 memcpy(sc->code, sc->value,
sizeof(
struct cell));
3437 s_return(sc, sc->value);
3442 if (is_pair(cdr(sc->args))) {
3443 if (cadr(sc->args) != sc->outport) {
3444 x = cons(sc, sc->outport, sc->NIL);
3445 s_save(sc, OP_SET_OUTPORT, x, sc->NIL);
3446 sc->outport = cadr(sc->args);
3449 sc->args = car(sc->args);
3450 if (op == OP_WRITE) {
3455 s_goto(sc, OP_P0LIST);
3458 if (is_pair(sc->args)) {
3459 if (car(sc->args) != sc->outport) {
3460 x = cons(sc, sc->outport, sc->NIL);
3461 s_save(sc, OP_SET_OUTPORT, x, sc->NIL);
3462 sc->outport = car(sc->args);
3466 s_return(sc, sc->T);
3470 if (!is_string(car(sc->args))) {
3471 sc->args = cons(sc, mk_string(sc,
" -- "), sc->args);
3472 setimmutable(car(sc->args));
3474 putstr(sc,
"Error: ");
3475 putstr(sc, strvalue(car(sc->args)));
3476 sc->args = cdr(sc->args);
3477 s_goto(sc, OP_ERR1);
3481 if (sc->args != sc->NIL) {
3482 s_save(sc, OP_ERR1, cdr(sc->args), sc->NIL);
3483 sc->args = car(sc->args);
3485 s_goto(sc, OP_P0LIST);
3488 if (sc->interactive_repl) {
3489 s_goto(sc, OP_T0LVL);
3495 case OP_REVERSE: s_return(sc, reverse(sc, car(sc->args)));
3497 case OP_LIST_STAR: s_return(sc, list_star(sc, sc->args));
3500 if (sc->args == sc->NIL) {
3501 s_return(sc, sc->NIL);
3504 if (cdr(sc->args) == sc->NIL) {
3505 s_return(sc, sc->args);
3507 for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
3508 x = append(sc, x, car(y));
3514 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3515 Error_0(sc,
"illegal use of put");
3517 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3523 cdar(x) = caddr(sc->args);
3525 symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), symprop(car(sc->args)));
3526 s_return(sc, sc->T);
3529 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3530 Error_0(sc,
"illegal use of get");
3532 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3538 s_return(sc, cdar(x));
3540 s_return(sc, sc->NIL);
3544 if (is_pair(sc->args)) {
3545 sc->retcode = ivalue(car(sc->args));
3549 case OP_GC: gc(sc, sc->NIL, sc->NIL); s_return(sc, sc->T);
3553 int was = sc->gc_verbose;
3555 sc->gc_verbose = (car(sc->args) != sc->F);
3560 if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3561 Error_0(sc,
"new-segment: argument must be a number");
3563 alloc_cellseg(sc, (
int)ivalue(car(sc->args)));
3564 s_return(sc, sc->T);
3566 case OP_OBLIST: s_return(sc, oblist_all_symbols(sc));
3568 case OP_CURR_INPORT: s_return(sc, sc->inport);
3570 case OP_CURR_OUTPORT: s_return(sc, sc->outport);
3572 case OP_OPEN_INFILE:
3573 case OP_OPEN_OUTFILE:
3574 case OP_OPEN_INOUTFILE:
3579 case OP_OPEN_INFILE: prop = port_input;
break;
3580 case OP_OPEN_OUTFILE: prop = port_output;
break;
3581 case OP_OPEN_INOUTFILE: prop = port_input | port_output;
break;
3584 p = port_from_filename(sc, strvalue(car(sc->args)), prop);
3586 s_return(sc, sc->F);
3591 #if USE_STRING_PORTS
3592 case OP_OPEN_INSTRING:
3593 case OP_OPEN_OUTSTRING:
3594 case OP_OPEN_INOUTSTRING:
3599 case OP_OPEN_INSTRING: prop = port_input;
break;
3600 case OP_OPEN_OUTSTRING: prop = port_output;
break;
3601 case OP_OPEN_INOUTSTRING: prop = port_input | port_output;
break;
3604 p = port_from_string(
3605 sc, strvalue(car(sc->args)), strvalue(car(sc->args)) + strlength(car(sc->args)), prop
3608 s_return(sc, sc->F);
3614 case OP_CLOSE_INPORT: port_close(sc, car(sc->args), port_input); s_return(sc, sc->T);
3616 case OP_CLOSE_OUTPORT: port_close(sc, car(sc->args), port_output); s_return(sc, sc->T);
3618 case OP_INT_ENV: s_return(sc, sc->global_env);
3620 case OP_CURR_ENV: s_return(sc, sc->envir);
3627 opexe_5(scheme* sc,
enum scheme_opcodes op) {
3630 if (sc->nesting != 0) {
3631 int n = sc->nesting;
3634 Error_1(sc,
"unmatched parentheses:", mk_integer(sc, n));
3640 if (!is_pair(sc->args)) {
3641 s_goto(sc, OP_READ_INTERNAL);
3643 if (!is_inport(car(sc->args))) {
3644 Error_1(sc,
"read: not an input port:", car(sc->args));
3646 if (car(sc->args) == sc->inport) {
3647 s_goto(sc, OP_READ_INTERNAL);
3650 sc->inport = car(sc->args);
3651 x = cons(sc, x, sc->NIL);
3652 s_save(sc, OP_SET_INPORT, x, sc->NIL);
3653 s_goto(sc, OP_READ_INTERNAL);
3659 if (is_pair(sc->args)) {
3660 if (car(sc->args) != sc->inport) {
3662 x = cons(sc, x, sc->NIL);
3663 s_save(sc, OP_SET_INPORT, x, sc->NIL);
3664 sc->inport = car(sc->args);
3669 s_return(sc, sc->EOF_OBJ);
3671 if (sc->op == OP_PEEK_CHAR) {
3674 s_return(sc, mk_character(sc, c));
3679 pointer p = sc->inport;
3681 if (is_pair(sc->args)) {
3684 res = p->_object._port->kind & port_string;
3688 case OP_SET_INPORT: sc->inport = car(sc->args); s_return(sc, sc->value);
3690 case OP_SET_OUTPORT: sc->outport = car(sc->args); s_return(sc, sc->value);
3695 if (sc->inport == sc->loadport) {
3697 s_goto(sc, OP_QUIT);
3699 s_return(sc, sc->EOF_OBJ);
3704 while ((c = inchar(sc)) !=
'\n' && c != EOF)
3706 sc->tok = token(sc);
3707 s_goto(sc, OP_RDSEXPR);
3710 s_save(sc, OP_RDVEC, sc->NIL, sc->NIL);
3713 sc->tok = token(sc);
3714 if (sc->tok == TOK_RPAREN) {
3715 s_return(sc, sc->NIL);
3716 }
else if (sc->tok == TOK_DOT) {
3717 Error_0(sc,
"syntax error: illegal dot expression");
3719 sc->nesting_stack[sc->file_i]++;
3720 s_save(sc, OP_RDLIST, sc->NIL, sc->NIL);
3721 s_goto(sc, OP_RDSEXPR);
3724 s_save(sc, OP_RDQUOTE, sc->NIL, sc->NIL);
3725 sc->tok = token(sc);
3726 s_goto(sc, OP_RDSEXPR);
3728 sc->tok = token(sc);
3729 if (sc->tok == TOK_VEC) {
3730 s_save(sc, OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
3731 sc->tok = TOK_LPAREN;
3732 s_goto(sc, OP_RDSEXPR);
3734 s_save(sc, OP_RDQQUOTE, sc->NIL, sc->NIL);
3736 s_goto(sc, OP_RDSEXPR);
3738 s_save(sc, OP_RDUNQUOTE, sc->NIL, sc->NIL);
3739 sc->tok = token(sc);
3740 s_goto(sc, OP_RDSEXPR);
3742 s_save(sc, OP_RDUQTSP, sc->NIL, sc->NIL);
3743 sc->tok = token(sc);
3744 s_goto(sc, OP_RDSEXPR);
3745 case TOK_ATOM: s_return(sc, mk_atom(sc, readstr_upto(sc,
"();\t\n\r ")));
3749 Error_0(sc,
"Error reading string");
3755 pointer f = find_slot_in_env(sc, sc->envir, sc->SHARP_HOOK, 1);
3757 Error_0(sc,
"undefined sharp expression");
3759 sc->code = cons(sc, slot_value_in_env(f), sc->NIL);
3760 s_goto(sc, OP_EVAL);
3763 case TOK_SHARP_CONST:
3764 if ((x = mk_sharp_const(sc, readstr_upto(sc,
"();\t\n\r "))) == sc->NIL) {
3765 Error_0(sc,
"undefined sharp expression");
3769 default: Error_0(sc,
"syntax error: illegal token");
3775 sc->args = cons(sc, sc->value, sc->args);
3776 sc->tok = token(sc);
3777 if (sc->tok == TOK_COMMENT) {
3779 while ((c = inchar(sc)) !=
'\n' && c != EOF)
3781 sc->tok = token(sc);
3783 if (sc->tok == TOK_RPAREN) {
3787 sc->nesting_stack[sc->file_i]--;
3788 s_return(sc, reverse_in_place(sc, sc->NIL, sc->args));
3789 }
else if (sc->tok == TOK_DOT) {
3790 s_save(sc, OP_RDDOT, sc->args, sc->NIL);
3791 sc->tok = token(sc);
3792 s_goto(sc, OP_RDSEXPR);
3794 s_save(sc, OP_RDLIST, sc->args, sc->NIL);
3796 s_goto(sc, OP_RDSEXPR);
3801 if (token(sc) != TOK_RPAREN) {
3802 Error_0(sc,
"syntax error: illegal dot expression");
3804 sc->nesting_stack[sc->file_i]--;
3805 s_return(sc, reverse_in_place(sc, sc->value, sc->args));
3808 case OP_RDQUOTE: s_return(sc, cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
3810 case OP_RDQQUOTE: s_return(sc, cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
3812 case OP_RDQQUOTEVEC:
3815 sc, mk_symbol(sc,
"apply"),
3817 sc, mk_symbol(sc,
"vector"),
3818 cons(sc, cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)), sc->NIL)
3823 case OP_RDUNQUOTE: s_return(sc, cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
3825 case OP_RDUQTSP: s_return(sc, cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
3835 sc->args = sc->value;
3836 s_goto(sc, OP_VECTOR);
3840 if (is_vector(sc->args)) {
3842 sc->args = cons(sc, sc->args, mk_integer(sc, 0));
3843 s_goto(sc, OP_PVECFROM);
3844 }
else if (is_environment(sc->args)) {
3845 putstr(sc,
"#<ENVIRONMENT>");
3846 s_return(sc, sc->T);
3847 }
else if (!is_pair(sc->args)) {
3848 printatom(sc, sc->args, sc->print_flag);
3849 s_return(sc, sc->T);
3850 }
else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
3852 sc->args = cadr(sc->args);
3853 s_goto(sc, OP_P0LIST);
3854 }
else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
3856 sc->args = cadr(sc->args);
3857 s_goto(sc, OP_P0LIST);
3858 }
else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
3860 sc->args = cadr(sc->args);
3861 s_goto(sc, OP_P0LIST);
3862 }
else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
3864 sc->args = cadr(sc->args);
3865 s_goto(sc, OP_P0LIST);
3868 s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
3869 sc->args = car(sc->args);
3870 s_goto(sc, OP_P0LIST);
3874 if (is_pair(sc->args)) {
3875 s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
3877 sc->args = car(sc->args);
3878 s_goto(sc, OP_P0LIST);
3879 }
else if (is_vector(sc->args)) {
3880 s_save(sc, OP_P1LIST, sc->NIL, sc->NIL);
3882 s_goto(sc, OP_P0LIST);
3884 if (sc->args != sc->NIL) {
3886 printatom(sc, sc->args, sc->print_flag);
3889 s_return(sc, sc->T);
3893 int i = ivalue_unchecked(cdr(sc->args));
3894 pointer vec = car(sc->args);
3895 int len = ivalue_unchecked(vec);
3898 s_return(sc, sc->T);
3900 pointer elem = vector_elem(vec, i);
3901 ivalue_unchecked(cdr(sc->args)) = i + 1;
3902 s_save(sc, OP_PVECFROM, sc->args, sc->NIL);
3905 s_goto(sc, OP_P0LIST);
3909 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3915 opexe_6(scheme* sc,
enum scheme_opcodes op) {
3920 case OP_LIST_LENGTH:
3921 v = list_length(sc, car(sc->args));
3923 Error_1(sc,
"length: not a list:", car(sc->args));
3925 s_return(sc, mk_integer(sc, v));
3929 for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
3930 if (!is_pair(car(y))) {
3931 Error_0(sc,
"unable to handle non pair element");
3937 s_return(sc, car(y));
3939 s_return(sc, sc->F);
3942 case OP_GET_CLOSURE:
3943 sc->args = car(sc->args);
3944 if (sc->args == sc->NIL) {
3945 s_return(sc, sc->F);
3946 }
else if (is_closure(sc->args)) {
3947 s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
3948 }
else if (is_macro(sc->args)) {
3949 s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
3951 s_return(sc, sc->F);
3958 s_retbool(is_closure(car(sc->args)));
3959 case OP_MACROP: s_retbool(is_macro(car(sc->args)));
3960 default: sprintf(sc->strbuff,
"%d: illegal operator", sc->op); Error_0(sc, sc->strbuff);
3965 typedef pointer (*dispatch_func)(scheme*,
enum scheme_opcodes);
3967 typedef int (*test_predicate)(pointer);
3975 is_num_integer(pointer p) {
3976 return is_number(p) && ((p)->_object._number.is_fixnum);
3980 is_nonneg(pointer p) {
3981 return is_num_integer(p) && ivalue(p) >= 0;
3991 { is_string,
"string"},
3992 { is_symbol,
"symbol"},
3995 { 0,
"output_port"},
3996 {is_environment,
"environment"},
3998 { 0,
"pair or '()"},
3999 { is_character,
"character"},
4000 { is_vector,
"vector"},
4001 { is_number,
"number"},
4002 {is_num_integer,
"integer"},
4003 { is_nonneg,
"non-negative integer"}
4007 #define TST_ANY "\001"
4008 #define TST_STRING "\002"
4009 #define TST_SYMBOL "\003"
4010 #define TST_PORT "\004"
4011 #define TST_INPORT "\005"
4012 #define TST_OUTPORT "\006"
4013 #define TST_ENVIRONMENT "\007"
4014 #define TST_PAIR "\010"
4015 #define TST_LIST "\011"
4016 #define TST_CHAR "\012"
4017 #define TST_VECTOR "\013"
4018 #define TST_NUMBER "\014"
4019 #define TST_INTEGER "\015"
4020 #define TST_NATURAL "\016"
4027 char* arg_tests_encoding;
4030 #define INF_ARG 0xffff
4032 static op_code_info dispatch_table[] = {
4033 #define _OP_DEF(A, B, C, D, E, OP) { A, B, C, D, E },
4039 procname(pointer x) {
4041 const char* name = dispatch_table[n].name;
4050 Eval_Cycle(scheme* sc,
enum scheme_opcodes op) {
4056 op_code_info* pcd = dispatch_table + sc->op;
4057 if (pcd->name != 0) {
4060 int n = list_length(sc, sc->args);
4063 if (n < pcd->min_arity) {
4066 msg,
"%s: needs%s %d argument(s)", pcd->name, pcd->min_arity == pcd->max_arity ?
"" :
" at least",
4070 if (ok && n > pcd->max_arity) {
4073 msg,
"%s: needs%s %d argument(s)", pcd->name, pcd->min_arity == pcd->max_arity ?
"" :
" at most",
4078 if (pcd->arg_tests_encoding != 0) {
4081 const char* t = pcd->arg_tests_encoding;
4082 pointer arglist = sc->args;
4084 pointer arg = car(arglist);
4086 if (j == TST_INPORT[0]) {
4087 if (!is_inport(arg))
4089 }
else if (j == TST_OUTPORT[0]) {
4090 if (!is_outport(arg))
4092 }
else if (j == TST_LIST[0]) {
4093 if (arg != sc->NIL && !is_pair(arg))
4096 if (!tests[j].fct(arg))
4103 arglist = cdr(arglist);
4108 sprintf(msg,
"%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);
4113 if (_Error_1(sc, msg, 0) == sc->NIL) {
4116 pcd = dispatch_table + sc->op;
4120 if (pcd->func(sc, (
enum scheme_opcodes)sc->op) == sc->NIL) {
4123 if (sc->no_memory) {
4124 fprintf(stderr,
"No memory!\n");
4134 assign_syntax(scheme* sc,
char* name) {
4137 x = oblist_add_by_name(sc, name);
4138 typeflag(x) |= T_SYNTAX;
4142 assign_proc(scheme* sc,
enum scheme_opcodes op,
char* name) {
4145 x = mk_symbol(sc, name);
4146 y = mk_proc(sc, op);
4147 new_slot_in_env(sc, x, y);
4151 mk_proc(scheme* sc,
enum scheme_opcodes op) {
4154 y = get_cell(sc, sc->NIL, sc->NIL);
4155 typeflag(y) = (T_PROC | T_ATOM);
4156 ivalue_unchecked(y) = (long)op;
4163 syntaxnum(pointer p) {
4164 const char* s = strvalue(car(p));
4165 switch (strlength(car(p))) {
4178 case 'e':
return OP_CASE0;
4179 case 'd':
return OP_COND0;
4180 case '*':
return OP_LET0AST;
4181 default:
return OP_SET0;
4185 case 'g':
return OP_BEGIN;
4186 case 'l':
return OP_DELAY;
4187 case 'c':
return OP_MACRO0;
4188 default:
return OP_QUOTE;
4192 case 'm':
return OP_LAMBDA;
4193 case 'f':
return OP_DEF0;
4194 default:
return OP_LET0REC;
4196 default:
return OP_C0STREAM;
4202 INTERFACE
static pointer
4203 s_cons(scheme* sc, pointer a, pointer b) {
4204 return cons(sc, a, b);
4207 INTERFACE
static pointer
4208 s_immutable_cons(scheme* sc, pointer a, pointer b) {
4209 return immutable_cons(sc, a, b);
4212 static struct scheme_interface vtbl = { scheme_define,
4268 scheme_load_string };
4273 scheme* sc = (scheme*)malloc(
sizeof(scheme));
4274 if (!scheme_init(sc)) {
4283 scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
4284 scheme* sc = (scheme*)malloc(
sizeof(scheme));
4285 if (!scheme_init_custom_alloc(sc, malloc, free)) {
4294 scheme_init(scheme* sc) {
4295 return scheme_init_custom_alloc(sc, malloc, free);
4299 scheme_init_custom_alloc(scheme* sc, func_alloc malloc, func_dealloc free) {
4300 int i, n =
sizeof(dispatch_table) /
sizeof(dispatch_table[0]);
4303 num_zero.is_fixnum = 1;
4304 num_zero.value.ivalue = 0;
4305 num_one.is_fixnum = 1;
4306 num_one.value.ivalue = 1;
4312 sc->malloc = malloc;
4314 sc->last_cell_seg = -1;
4315 sc->sink = &sc->_sink;
4316 sc->NIL = &sc->_NIL;
4317 sc->T = &sc->_HASHT;
4318 sc->F = &sc->_HASHF;
4319 sc->EOF_OBJ = &sc->_EOF_OBJ;
4320 sc->free_cell = &sc->_NIL;
4323 sc->inport = sc->NIL;
4324 sc->outport = sc->NIL;
4325 sc->save_inport = sc->NIL;
4326 sc->loadport = sc->NIL;
4328 sc->interactive_repl = 0;
4330 if (alloc_cellseg(sc, FIRST_CELLSEGS) != FIRST_CELLSEGS) {
4335 dump_stack_initialize(sc);
4340 typeflag(sc->NIL) = (T_ATOM | MARK);
4341 car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
4343 typeflag(sc->T) = (T_ATOM | MARK);
4344 car(sc->T) = cdr(sc->T) = sc->T;
4346 typeflag(sc->F) = (T_ATOM | MARK);
4347 car(sc->F) = cdr(sc->F) = sc->F;
4348 sc->oblist = oblist_initial_value(sc);
4350 new_frame_in_env(sc, sc->NIL);
4351 sc->global_env = sc->envir;
4353 x = mk_symbol(sc,
"else");
4354 new_slot_in_env(sc, x, sc->T);
4356 assign_syntax(sc,
"lambda");
4357 assign_syntax(sc,
"quote");
4358 assign_syntax(sc,
"define");
4359 assign_syntax(sc,
"if");
4360 assign_syntax(sc,
"begin");
4361 assign_syntax(sc,
"set!");
4362 assign_syntax(sc,
"let");
4363 assign_syntax(sc,
"let*");
4364 assign_syntax(sc,
"letrec");
4365 assign_syntax(sc,
"cond");
4366 assign_syntax(sc,
"delay");
4367 assign_syntax(sc,
"and");
4368 assign_syntax(sc,
"or");
4369 assign_syntax(sc,
"cons-stream");
4370 assign_syntax(sc,
"macro");
4371 assign_syntax(sc,
"case");
4373 for (i = 0; i < n; i++) {
4374 if (dispatch_table[i].name != 0) {
4375 assign_proc(sc, (
enum scheme_opcodes)i, dispatch_table[i].name);
4380 sc->LAMBDA = mk_symbol(sc,
"lambda");
4381 sc->QUOTE = mk_symbol(sc,
"quote");
4382 sc->QQUOTE = mk_symbol(sc,
"quasiquote");
4383 sc->UNQUOTE = mk_symbol(sc,
"unquote");
4384 sc->UNQUOTESP = mk_symbol(sc,
"unquote-splicing");
4385 sc->FEED_TO = mk_symbol(sc,
"=>");
4386 sc->COLON_HOOK = mk_symbol(sc,
"*colon-hook*");
4387 sc->ERROR_HOOK = mk_symbol(sc,
"*error-hook*");
4388 sc->SHARP_HOOK = mk_symbol(sc,
"*sharp-hook*");
4390 return !sc->no_memory;
4394 scheme_set_input_port_file(scheme* sc, FILE* fin) {
4395 sc->inport = port_from_file(sc, fin, port_input);
4399 scheme_set_input_port_string(scheme* sc,
char* start,
char* past_the_end) {
4400 sc->inport = port_from_string(sc, start, past_the_end, port_input);
4404 scheme_set_output_port_file(scheme* sc, FILE* fout) {
4405 sc->outport = port_from_file(sc, fout, port_output);
4409 scheme_set_output_port_string(scheme* sc,
char* start,
char* past_the_end) {
4410 sc->outport = port_from_string(sc, start, past_the_end, port_output);
4414 scheme_set_external_data(scheme* sc,
void* p) {
4419 scheme_deinit(scheme* sc) {
4422 sc->oblist = sc->NIL;
4423 sc->global_env = sc->NIL;
4424 dump_stack_free(sc);
4425 sc->envir = sc->NIL;
4428 sc->value = sc->NIL;
4429 if (is_port(sc->inport)) {
4430 typeflag(sc->inport) = T_ATOM;
4432 sc->inport = sc->NIL;
4433 sc->outport = sc->NIL;
4434 if (is_port(sc->save_inport)) {
4435 typeflag(sc->save_inport) = T_ATOM;
4437 sc->save_inport = sc->NIL;
4438 if (is_port(sc->loadport)) {
4439 typeflag(sc->loadport) = T_ATOM;
4441 sc->loadport = sc->NIL;
4443 gc(sc, sc->NIL, sc->NIL);
4445 for (i = 0; i <= sc->last_cell_seg; i++) {
4446 sc->free(sc->alloc_seg[i]);
4451 scheme_load_file(scheme* sc, FILE* fin) {
4452 dump_stack_reset(sc);
4453 sc->envir = sc->global_env;
4455 sc->load_stack[0].kind = port_input | port_file;
4456 sc->load_stack[0].rep.stdio.file = fin;
4457 sc->loadport = mk_port(sc, sc->load_stack);
4460 sc->interactive_repl = 1;
4462 sc->inport = sc->loadport;
4463 Eval_Cycle(sc, OP_T0LVL);
4464 typeflag(sc->loadport) = T_ATOM;
4465 if (sc->retcode == 0) {
4466 sc->retcode = sc->nesting != 0;
4471 scheme_load_string(scheme* sc,
const char* cmd) {
4472 dump_stack_reset(sc);
4473 sc->envir = sc->global_env;
4475 sc->load_stack[0].kind = port_input | port_string;
4476 sc->load_stack[0].rep.string.start = (
char*)cmd;
4477 sc->load_stack[0].rep.string.past_the_end = (
char*)cmd + strlen(cmd);
4478 sc->load_stack[0].rep.string.curr = (
char*)cmd;
4479 sc->loadport = mk_port(sc, sc->load_stack);
4481 sc->interactive_repl = 0;
4482 sc->inport = sc->loadport;
4483 Eval_Cycle(sc, OP_T0LVL);
4484 typeflag(sc->loadport) = T_ATOM;
4485 if (sc->retcode == 0) {
4486 sc->retcode = sc->nesting != 0;
4491 scheme_define(scheme* sc, pointer envir, pointer symbol, pointer value) {
4494 x = find_slot_in_env(sc, envir, symbol, 0);
4496 set_slot_in_env(sc, x, value);
4498 new_slot_spec_in_env(sc, envir, symbol, value);
4504 scheme_apply0(scheme* sc,
const char* procname) {
4505 pointer carx = mk_symbol(sc, procname);
4506 pointer cdrx = sc->NIL;
4508 dump_stack_reset(sc);
4509 sc->envir = sc->global_env;
4510 sc->code = cons(sc, carx, cdrx);
4511 sc->interactive_repl = 0;
4513 Eval_Cycle(sc, OP_EVAL);
4517 scheme_call(scheme* sc, pointer func, pointer args) {
4518 dump_stack_reset(sc);
4519 sc->envir = sc->global_env;
4522 sc->interactive_repl = 0;
4524 Eval_Cycle(sc, OP_APPLY);
4535 extern MacTS_main(
int argc,
char** argv);
4537 int argc = ccommand(&argv);
4538 MacTS_main(argc, argv);
4542 MacTS_main(
int argc,
char** argv) {
4545 main(
int argc,
char** argv) {
4549 char* file_name = InitFile;
4556 if (argc == 2 && strcmp(argv[1],
"-?") == 0) {
4558 "Usage: %s [-? | <file1> <file2> ... | -1 <file> <arg1> <arg2> ...]\n\tUse - as filename for stdin.\n",
4563 if (!scheme_init(&sc)) {
4564 fprintf(stderr,
"Could not initialize!\n");
4567 scheme_set_input_port_file(&sc, stdin);
4568 scheme_set_output_port_file(&sc, stdout);
4570 scheme_define(&sc, sc.global_env, mk_symbol(&sc,
"load-extension"), mk_foreign_func(&sc, scm_load_ext));
4573 if (access(file_name, 0) != 0) {
4574 char* p = getenv(
"TINYSCHEMEINIT");
4580 if (strcmp(file_name,
"-") == 0) {
4582 }
else if (strcmp(file_name,
"-1") == 0 || strcmp(file_name,
"-c") == 0) {
4583 pointer args = sc.NIL;
4584 isfile = file_name[1] ==
'1';
4585 file_name = *argv++;
4586 if (strcmp(file_name,
"-") == 0) {
4588 }
else if (isfile) {
4589 fin = fopen(file_name,
"r");
4591 for (; *argv; argv++) {
4592 pointer value = mk_string(&sc, *argv);
4593 args = cons(&sc, value, args);
4595 args = reverse_in_place(&sc, sc.NIL, args);
4596 scheme_define(&sc, sc.global_env, mk_symbol(&sc,
"*args*"), args);
4599 fin = fopen(file_name,
"r");
4601 if (isfile && fin == 0) {
4602 fprintf(stderr,
"Could not open file %s\n", file_name);
4605 scheme_load_file(&sc, fin);
4607 scheme_load_string(&sc, file_name);
4609 if (!isfile || fin != stdin) {
4610 if (sc.retcode != 0) {
4611 fprintf(stderr,
"Errors encountered reading %s\n", file_name);
4618 file_name = *argv++;
4619 }
while (file_name != 0);
4621 scheme_load_file(&sc, stdin);
4623 retcode = sc.retcode;
Header info for the dynamic loader functions for TinyScheme.
More support data for the TinyScheme parser.
Private data for the TinyScheme compiler.