00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00020 #ifdef HAVE_CONFIG_H
00021 #include <config.h>
00022 #endif
00023
00024 #define _SCHEME_SOURCE
00025 #include "scheme-private.h"
00026 #ifndef WIN32
00027 # include <unistd.h>
00028 #endif
00029 #if USE_DL
00030 # include "dynload.h"
00031 #endif
00032 #if USE_MATH
00033 # include <math.h>
00034 #endif
00035 #include <limits.h>
00036 #include <float.h>
00037 #include <ctype.h>
00038 #ifdef HAVE_UNISTD_H
00039 #include <unistd.h>
00040 #endif
00041
00042 #if USE_STRCASECMP
00043 #include <strings.h>
00044 #define stricmp strcasecmp
00045 #endif
00046
00047
00048 #define INTERFACE
00049
00050 #define TOK_EOF (-1)
00051 #define TOK_LPAREN 0
00052 #define TOK_RPAREN 1
00053 #define TOK_DOT 2
00054 #define TOK_ATOM 3
00055 #define TOK_QUOTE 4
00056 #define TOK_COMMENT 5
00057 #define TOK_DQUOTE 6
00058 #define TOK_BQUOTE 7
00059 #define TOK_COMMA 8
00060 #define TOK_ATMARK 9
00061 #define TOK_SHARP 10
00062 #define TOK_SHARP_CONST 11
00063 #define TOK_VEC 12
00064
00065 # define BACKQUOTE '`'
00066
00067
00068
00069
00070
00071 #define banner "TinyScheme 1.35"
00072
00073 #ifdef HAVE_STRING_H
00074 #include <string.h>
00075 #endif
00076 #include <stdlib.h>
00077 #ifndef macintosh
00078 #ifdef HAVE_MALLOC_H
00079 # include <malloc.h>
00080 #endif
00081 #else
00082 static int stricmp(const char *s1, const char *s2)
00083 {
00084 unsigned char c1, c2;
00085 do {
00086 c1 = tolower(*s1);
00087 c2 = tolower(*s2);
00088 if (c1 < c2)
00089 return -1;
00090 else if (c1 > c2)
00091 return 1;
00092 s1++, s2++;
00093 } while (c1 != 0);
00094 return 0;
00095 }
00096 #endif
00097
00098 #ifndef HAVE_STRLWR
00099 static const char *strlwr(char *s) {
00100 const char *p=s;
00101 while(*s) {
00102 *s=tolower((int) *s);
00103 s++;
00104 }
00105 return p;
00106 }
00107 #endif
00108
00109 #ifndef prompt
00110 # define prompt "> "
00111 #endif
00112
00113 #ifndef InitFile
00114 # define InitFile "init.scm"
00115 #endif
00116
00117 #ifndef FIRST_CELLSEGS
00118 # define FIRST_CELLSEGS 3
00119 #endif
00120
00121 enum scheme_types {
00122 T_STRING=1,
00123 T_NUMBER=2,
00124 T_SYMBOL=3,
00125 T_PROC=4,
00126 T_PAIR=5,
00127 T_CLOSURE=6,
00128 T_CONTINUATION=7,
00129 T_FOREIGN=8,
00130 T_CHARACTER=9,
00131 T_PORT=10,
00132 T_VECTOR=11,
00133 T_MACRO=12,
00134 T_PROMISE=13,
00135 T_ENVIRONMENT=14,
00136 T_LAST_SYSTEM_TYPE=14
00137 };
00138
00139
00140 #define ADJ 32
00141 #define TYPE_BITS 5
00142 #define T_MASKTYPE 31
00143 #define T_SYNTAX 4096
00144 #define T_IMMUTABLE 8192
00145 #define T_ATOM 16384
00146 #define CLRATOM 49151
00147 #define MARK 32768
00148 #define UNMARK 32767
00149
00150
00151 static num num_add(num a, num b);
00152 static num num_mul(num a, num b);
00153 static num num_div(num a, num b);
00154 static num num_intdiv(num a, num b);
00155 static num num_sub(num a, num b);
00156 static num num_rem(num a, num b);
00157 static num num_mod(num a, num b);
00158 static int num_eq(num a, num b);
00159 static int num_gt(num a, num b);
00160 static int num_ge(num a, num b);
00161 static int num_lt(num a, num b);
00162 static int num_le(num a, num b);
00163
00164 #if USE_MATH
00165 static double round_per_R5RS(double x);
00166 #endif
00167 static int is_zero_double(double x);
00168
00169 static num num_zero;
00170 static num num_one;
00171
00172
00173 #define typeflag(p) ((p)->_flag)
00174 #define type(p) (typeflag(p)&T_MASKTYPE)
00175
00176 INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
00177 #define strvalue(p) ((p)->_object._string._svalue)
00178 #define strlength(p) ((p)->_object._string._length)
00179
00180 INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
00181 INTERFACE static void fill_vector(pointer vec, pointer obj);
00182 INTERFACE static pointer vector_elem(pointer vec, int ielem);
00183 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
00184 INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
00185 INTERFACE INLINE int is_integer(pointer p) {
00186 return ((p)->_object._number.is_fixnum);
00187 }
00188 INTERFACE INLINE int is_real(pointer p) {
00189 return (!(p)->_object._number.is_fixnum);
00190 }
00191
00192 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
00193 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
00194 INLINE num nvalue(pointer p) { return ((p)->_object._number); }
00195 INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
00196 INTERFACE double rvalue(pointer p) { return (!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
00197 #define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
00198 #define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
00199 #define set_integer(p) (p)->_object._number.is_fixnum=1;
00200 #define set_real(p) (p)->_object._number.is_fixnum=0;
00201 INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); }
00202
00203 INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
00204 #define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input)
00205 #define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output)
00206
00207 INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
00208 #define car(p) ((p)->_object._cons._car)
00209 #define cdr(p) ((p)->_object._cons._cdr)
00210 INTERFACE pointer pair_car(pointer p) { return car(p); }
00211 INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
00212 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
00213 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
00214
00215 INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
00216 INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
00217 #if USE_PLIST
00218 SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
00219 #define symprop(p) cdr(p)
00220 #endif
00221
00222 INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
00223 INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
00224 INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
00225 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
00226 #define procnum(p) ivalue(p)
00227 static const char *procname(pointer x);
00228
00229 INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
00230 INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
00231 INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
00232 INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
00233
00234 INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
00235 #define cont_dump(p) cdr(p)
00236
00237
00238 INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
00239
00240 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
00241 #define setenvironment(p) typeflag(p) = T_ENVIRONMENT
00242
00243 #define is_atom(p) (typeflag(p)&T_ATOM)
00244 #define setatom(p) typeflag(p) |= T_ATOM
00245 #define clratom(p) typeflag(p) &= CLRATOM
00246
00247 #define is_mark(p) (typeflag(p)&MARK)
00248 #define setmark(p) typeflag(p) |= MARK
00249 #define clrmark(p) typeflag(p) &= UNMARK
00250
00251 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
00252
00253 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
00254
00255 #define caar(p) car(car(p))
00256 #define cadr(p) car(cdr(p))
00257 #define cdar(p) cdr(car(p))
00258 #define cddr(p) cdr(cdr(p))
00259 #define cadar(p) car(cdr(car(p)))
00260 #define caddr(p) car(cdr(cdr(p)))
00261 #define cadaar(p) car(cdr(car(car(p))))
00262 #define cadddr(p) car(cdr(cdr(cdr(p))))
00263 #define cddddr(p) cdr(cdr(cdr(cdr(p))))
00264
00265 #if USE_CHAR_CLASSIFIERS
00266 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
00267 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
00268 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
00269 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
00270 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
00271 #endif
00272
00273 #if USE_ASCII_NAMES
00274 static const char *charnames[32]={
00275 "nul",
00276 "soh",
00277 "stx",
00278 "etx",
00279 "eot",
00280 "enq",
00281 "ack",
00282 "bel",
00283 "bs",
00284 "ht",
00285 "lf",
00286 "vt",
00287 "ff",
00288 "cr",
00289 "so",
00290 "si",
00291 "dle",
00292 "dc1",
00293 "dc2",
00294 "dc3",
00295 "dc4",
00296 "nak",
00297 "syn",
00298 "etb",
00299 "can",
00300 "em",
00301 "sub",
00302 "esc",
00303 "fs",
00304 "gs",
00305 "rs",
00306 "us"
00307 };
00308
00309 static int is_ascii_name(const char *name, int *pc) {
00310 int i;
00311 for(i=0; i<32; i++) {
00312 if(stricmp(name,charnames[i])==0) {
00313 *pc=i;
00314 return 1;
00315 }
00316 }
00317 if(stricmp(name,"del")==0) {
00318 *pc=127;
00319 return 1;
00320 }
00321 return 0;
00322 }
00323
00324 #endif
00325
00326 static int file_push(scheme *sc, const char *fname);
00327 static void file_pop(scheme *sc);
00328 static int file_interactive(scheme *sc);
00329 static INLINE int is_one_of(char *s, int c);
00330 static int alloc_cellseg(scheme *sc, int n);
00331 static long binary_decode(const char *s);
00332 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
00333 static pointer _get_cell(scheme *sc, pointer a, pointer b);
00334 static pointer get_consecutive_cells(scheme *sc, int n);
00335 static pointer find_consecutive_cells(scheme *sc, int n);
00336 static void finalize_cell(scheme *sc, pointer a);
00337 static int count_consecutive_cells(pointer x, int needed);
00338 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
00339 static pointer mk_number(scheme *sc, num n);
00340 static pointer mk_empty_string(scheme *sc, int len, char fill);
00341 static char *store_string(scheme *sc, int len, const char *str, char fill);
00342 static pointer mk_vector(scheme *sc, int len);
00343 static pointer mk_atom(scheme *sc, char *q);
00344 static pointer mk_sharp_const(scheme *sc, char *name);
00345 static pointer mk_port(scheme *sc, port *p);
00346 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
00347 static pointer port_from_file(scheme *sc, FILE *, int prop);
00348 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
00349 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
00350 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
00351 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
00352 static void port_close(scheme *sc, pointer p, int flag);
00353 static void mark(pointer a);
00354 static void gc(scheme *sc, pointer a, pointer b);
00355 static int basic_inchar(port *pt);
00356 static int inchar(scheme *sc);
00357 static void backchar(scheme *sc, int c);
00358 static char *readstr_upto(scheme *sc, char *delim);
00359 static pointer readstrexp(scheme *sc);
00360 static INLINE void skipspace(scheme *sc);
00361 static int token(scheme *sc);
00362 static void printslashstring(scheme *sc, char *s, int len);
00363 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
00364 static void printatom(scheme *sc, pointer l, int f);
00365 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
00366 static pointer mk_closure(scheme *sc, pointer c, pointer e);
00367 static pointer mk_continuation(scheme *sc, pointer d);
00368 static pointer reverse(scheme *sc, pointer a);
00369 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
00370 static pointer append(scheme *sc, pointer a, pointer b);
00371 static int list_length(scheme *sc, pointer a);
00372 static int eqv(pointer a, pointer b);
00373 static void dump_stack_mark(scheme *);
00374 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
00375 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
00376 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
00377 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
00378 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
00379 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
00380 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
00381 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
00382 static void assign_syntax(scheme *sc, char *name);
00383 static int syntaxnum(pointer p);
00384 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
00385
00386 #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
00387 #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
00388
00389 static num num_add(num a, num b) {
00390 num ret;
00391 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00392 if(ret.is_fixnum) {
00393 ret.value.ivalue= a.value.ivalue+b.value.ivalue;
00394 } else {
00395 ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
00396 }
00397 return ret;
00398 }
00399
00400 static num num_mul(num a, num b) {
00401 num ret;
00402 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00403 if(ret.is_fixnum) {
00404 ret.value.ivalue= a.value.ivalue*b.value.ivalue;
00405 } else {
00406 ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
00407 }
00408 return ret;
00409 }
00410
00411 static num num_div(num a, num b) {
00412 num ret;
00413 ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
00414 if(ret.is_fixnum) {
00415 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
00416 } else {
00417 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
00418 }
00419 return ret;
00420 }
00421
00422 static num num_intdiv(num a, num b) {
00423 num ret;
00424 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00425 if(ret.is_fixnum) {
00426 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
00427 } else {
00428 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
00429 }
00430 return ret;
00431 }
00432
00433 static num num_sub(num a, num b) {
00434 num ret;
00435 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00436 if(ret.is_fixnum) {
00437 ret.value.ivalue= a.value.ivalue-b.value.ivalue;
00438 } else {
00439 ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
00440 }
00441 return ret;
00442 }
00443
00444 static num num_rem(num a, num b) {
00445 num ret;
00446 long e1, e2, res;
00447 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00448 e1=num_ivalue(a);
00449 e2=num_ivalue(b);
00450 res=e1%e2;
00451
00452 if (res > 0) {
00453 if (e1 < 0) {
00454 res -= labs(e2);
00455 }
00456 } else if (res < 0) {
00457 if (e1 > 0) {
00458 res += labs(e2);
00459 }
00460 }
00461 ret.value.ivalue=res;
00462 return ret;
00463 }
00464
00465 static num num_mod(num a, num b) {
00466 num ret;
00467 long e1, e2, res;
00468 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00469 e1=num_ivalue(a);
00470 e2=num_ivalue(b);
00471 res=e1%e2;
00472 if(res*e2<0) {
00473 e2=labs(e2);
00474 if(res>0) {
00475 res-=e2;
00476 } else {
00477 res+=e2;
00478 }
00479 }
00480 ret.value.ivalue=res;
00481 return ret;
00482 }
00483
00484 static int num_eq(num a, num b) {
00485 int ret;
00486 int is_fixnum=a.is_fixnum && b.is_fixnum;
00487 if(is_fixnum) {
00488 ret= a.value.ivalue==b.value.ivalue;
00489 } else {
00490 ret=num_rvalue(a)==num_rvalue(b);
00491 }
00492 return ret;
00493 }
00494
00495
00496 static int num_gt(num a, num b) {
00497 int ret;
00498 int is_fixnum=a.is_fixnum && b.is_fixnum;
00499 if(is_fixnum) {
00500 ret= a.value.ivalue>b.value.ivalue;
00501 } else {
00502 ret=num_rvalue(a)>num_rvalue(b);
00503 }
00504 return ret;
00505 }
00506
00507 static int num_ge(num a, num b) {
00508 return !num_lt(a,b);
00509 }
00510
00511 static int num_lt(num a, num b) {
00512 int ret;
00513 int is_fixnum=a.is_fixnum && b.is_fixnum;
00514 if(is_fixnum) {
00515 ret= a.value.ivalue<b.value.ivalue;
00516 } else {
00517 ret=num_rvalue(a)<num_rvalue(b);
00518 }
00519 return ret;
00520 }
00521
00522 static int num_le(num a, num b) {
00523 return !num_gt(a,b);
00524 }
00525
00526 #if USE_MATH
00527
00528 static double round_per_R5RS(double x) {
00529 double fl=floor(x);
00530 double ce=ceil(x);
00531 double dfl=x-fl;
00532 double dce=ce-x;
00533 if(dfl>dce) {
00534 return ce;
00535 } else if(dfl<dce) {
00536 return fl;
00537 } else {
00538 if(fmod(fl,2.0)==0.0) {
00539 return fl;
00540 } else {
00541 return ce;
00542 }
00543 }
00544 }
00545 #endif
00546
00547 static int is_zero_double(double x) {
00548 return x<DBL_MIN && x>-DBL_MIN;
00549 }
00550
00551 static long binary_decode(const char *s) {
00552 long x=0;
00553
00554 while(*s!=0 && (*s=='1' || *s=='0')) {
00555 x<<=1;
00556 x+=*s-'0';
00557 s++;
00558 }
00559
00560 return x;
00561 }
00562
00563
00564 static int alloc_cellseg(scheme *sc, int n) {
00565 pointer newp;
00566 pointer last;
00567 pointer p;
00568 char *cp;
00569 long i;
00570 int k;
00571 int adj=ADJ;
00572
00573 if(adj<sizeof(struct cell)) {
00574 adj=sizeof(struct cell);
00575 }
00576
00577 for (k = 0; k < n; k++) {
00578 if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
00579 return k;
00580 cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
00581 if (cp == 0)
00582 return k;
00583 i = ++sc->last_cell_seg ;
00584 sc->alloc_seg[i] = cp;
00585
00586 if((unsigned long)cp%adj!=0) {
00587 cp=(char*)(adj*((unsigned long)cp/adj+1));
00588 }
00589
00590 newp=(pointer)cp;
00591 sc->cell_seg[i] = newp;
00592 while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
00593 p = sc->cell_seg[i];
00594 sc->cell_seg[i] = sc->cell_seg[i - 1];
00595 sc->cell_seg[--i] = p;
00596 }
00597 sc->fcells += CELL_SEGSIZE;
00598 last = newp + CELL_SEGSIZE - 1;
00599 for (p = newp; p <= last; p++) {
00600 typeflag(p) = 0;
00601 cdr(p) = p + 1;
00602 car(p) = sc->NIL;
00603 }
00604
00605 if (sc->free_cell == sc->NIL || p < sc->free_cell) {
00606 cdr(last) = sc->free_cell;
00607 sc->free_cell = newp;
00608 } else {
00609 p = sc->free_cell;
00610 while (cdr(p) != sc->NIL && newp > cdr(p))
00611 p = cdr(p);
00612 cdr(last) = cdr(p);
00613 cdr(p) = newp;
00614 }
00615 }
00616 return n;
00617 }
00618
00619 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) {
00620 if (sc->free_cell != sc->NIL) {
00621 pointer x = sc->free_cell;
00622 sc->free_cell = cdr(x);
00623 --sc->fcells;
00624 return (x);
00625 }
00626 return _get_cell (sc, a, b);
00627 }
00628
00629
00630
00631 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
00632 pointer x;
00633
00634 if(sc->no_memory) {
00635 return sc->sink;
00636 }
00637
00638 if (sc->free_cell == sc->NIL) {
00639 gc(sc,a, b);
00640 if (sc->fcells < sc->last_cell_seg*8
00641 || sc->free_cell == sc->NIL) {
00642
00643 if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
00644 sc->no_memory=1;
00645 return sc->sink;
00646 }
00647 }
00648 }
00649 x = sc->free_cell;
00650 sc->free_cell = cdr(x);
00651 --sc->fcells;
00652 return (x);
00653 }
00654
00655 static pointer get_consecutive_cells(scheme *sc, int n) {
00656 pointer x;
00657
00658 if(sc->no_memory) {
00659 return sc->sink;
00660 }
00661
00662
00663 x=find_consecutive_cells(sc,n);
00664 if (x == sc->NIL) {
00665
00666 gc(sc, sc->NIL, sc->NIL);
00667 x=find_consecutive_cells(sc,n);
00668 if (x == sc->NIL) {
00669
00670 if (!alloc_cellseg(sc,1)) {
00671 sc->no_memory=1;
00672 return sc->sink;
00673 }
00674 }
00675 x=find_consecutive_cells(sc,n);
00676 if (x == sc->NIL) {
00677
00678 sc->no_memory=1;
00679 return sc->sink;
00680 }
00681 }
00682 return (x);
00683 }
00684
00685 static int count_consecutive_cells(pointer x, int needed) {
00686 int n=1;
00687 while(cdr(x)==x+1) {
00688 x=cdr(x);
00689 n++;
00690 if(n>needed) return n;
00691 }
00692 return n;
00693 }
00694
00695 static pointer find_consecutive_cells(scheme *sc, int n) {
00696 pointer *pp;
00697 int cnt;
00698
00699 pp=&sc->free_cell;
00700 while(*pp!=sc->NIL) {
00701 cnt=count_consecutive_cells(*pp,n);
00702 if(cnt>=n) {
00703 pointer x=*pp;
00704 *pp=cdr(*pp+n-1);
00705 sc->fcells -= n;
00706 return x;
00707 }
00708 pp=&cdr(*pp+cnt-1);
00709 }
00710 return sc->NIL;
00711 }
00712
00713
00714 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
00715 pointer x = get_cell(sc,a, b);
00716
00717 typeflag(x) = T_PAIR;
00718 if(immutable) {
00719 setimmutable(x);
00720 }
00721 car(x) = a;
00722 cdr(x) = b;
00723 return (x);
00724 }
00725
00726
00727
00728 #ifndef USE_OBJECT_LIST
00729
00730 static int hash_fn(const char *key, int table_size);
00731
00732 static pointer oblist_initial_value(scheme *sc)
00733 {
00734 return mk_vector(sc, 461);
00735 }
00736
00737
00738 static pointer oblist_add_by_name(scheme *sc, const char *name)
00739 {
00740 pointer x;
00741 int location;
00742
00743 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
00744 typeflag(x) = T_SYMBOL;
00745 setimmutable(car(x));
00746
00747 location = hash_fn(name, ivalue_unchecked(sc->oblist));
00748 set_vector_elem(sc->oblist, location,
00749 immutable_cons(sc, x, vector_elem(sc->oblist, location)));
00750 return x;
00751 }
00752
00753 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
00754 {
00755 int location;
00756 pointer x;
00757 char *s;
00758
00759 location = hash_fn(name, ivalue_unchecked(sc->oblist));
00760 for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
00761 s = symname(car(x));
00762
00763 if(stricmp(name, s) == 0) {
00764 return car(x);
00765 }
00766 }
00767 return sc->NIL;
00768 }
00769
00770 static pointer oblist_all_symbols(scheme *sc)
00771 {
00772 int i;
00773 pointer x;
00774 pointer ob_list = sc->NIL;
00775
00776 for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
00777 for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
00778 ob_list = cons(sc, x, ob_list);
00779 }
00780 }
00781 return ob_list;
00782 }
00783
00784 #else
00785
00786 static pointer oblist_initial_value(scheme *sc)
00787 {
00788 return sc->NIL;
00789 }
00790
00791 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
00792 {
00793 pointer x;
00794 char *s;
00795
00796 for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
00797 s = symname(car(x));
00798
00799 if(stricmp(name, s) == 0) {
00800 return car(x);
00801 }
00802 }
00803 return sc->NIL;
00804 }
00805
00806
00807 static pointer oblist_add_by_name(scheme *sc, const char *name)
00808 {
00809 pointer x;
00810
00811 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
00812 typeflag(x) = T_SYMBOL;
00813 setimmutable(car(x));
00814 sc->oblist = immutable_cons(sc, x, sc->oblist);
00815 return x;
00816 }
00817 static pointer oblist_all_symbols(scheme *sc)
00818 {
00819 return sc->oblist;
00820 }
00821
00822 #endif
00823
00824 static pointer mk_port(scheme *sc, port *p) {
00825 pointer x = get_cell(sc, sc->NIL, sc->NIL);
00826
00827 typeflag(x) = T_PORT|T_ATOM;
00828 x->_object._port=p;
00829 return (x);
00830 }
00831
00832 pointer mk_foreign_func(scheme *sc, foreign_func f) {
00833 pointer x = get_cell(sc, sc->NIL, sc->NIL);
00834
00835 typeflag(x) = (T_FOREIGN | T_ATOM);
00836 x->_object._ff=f;
00837 return (x);
00838 }
00839
00840 INTERFACE pointer mk_character(scheme *sc, int c) {
00841 pointer x = get_cell(sc,sc->NIL, sc->NIL);
00842
00843 typeflag(x) = (T_CHARACTER | T_ATOM);
00844 ivalue_unchecked(x)= c;
00845 set_integer(x);
00846 return (x);
00847 }
00848
00849
00850 INTERFACE pointer mk_integer(scheme *sc, long num) {
00851 pointer x = get_cell(sc,sc->NIL, sc->NIL);
00852
00853 typeflag(x) = (T_NUMBER | T_ATOM);
00854 ivalue_unchecked(x)= num;
00855 set_integer(x);
00856 return (x);
00857 }
00858
00859 INTERFACE pointer mk_real(scheme *sc, double n) {
00860 pointer x = get_cell(sc,sc->NIL, sc->NIL);
00861
00862 typeflag(x) = (T_NUMBER | T_ATOM);
00863 rvalue_unchecked(x)= n;
00864 set_real(x);
00865 return (x);
00866 }
00867
00868 static pointer mk_number(scheme *sc, num n) {
00869 if(n.is_fixnum) {
00870 return mk_integer(sc,n.value.ivalue);
00871 } else {
00872 return mk_real(sc,n.value.rvalue);
00873 }
00874 }
00875
00876
00877 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
00878 char *q;
00879
00880 q=(char*)sc->malloc(len_str+1);
00881 if(q==0) {
00882 sc->no_memory=1;
00883 return sc->strbuff;
00884 }
00885 if(str!=0) {
00886 strcpy(q, str);
00887 } else {
00888 memset(q, fill, len_str);
00889 q[len_str]=0;
00890 }
00891 return (q);
00892 }
00893
00894
00895 INTERFACE pointer mk_string(scheme *sc, const char *str) {
00896 return mk_counted_string(sc,str,strlen(str));
00897 }
00898
00899 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
00900 pointer x = get_cell(sc, sc->NIL, sc->NIL);
00901
00902 strvalue(x) = store_string(sc,len,str,0);
00903 typeflag(x) = (T_STRING | T_ATOM);
00904 strlength(x) = len;
00905 return (x);
00906 }
00907
00908 static pointer mk_empty_string(scheme *sc, int len, char fill) {
00909 pointer x = get_cell(sc, sc->NIL, sc->NIL);
00910
00911 strvalue(x) = store_string(sc,len,0,fill);
00912 typeflag(x) = (T_STRING | T_ATOM);
00913 strlength(x) = len;
00914 return (x);
00915 }
00916
00917 INTERFACE static pointer mk_vector(scheme *sc, int len) {
00918 pointer x=get_consecutive_cells(sc,len/2+len%2+1);
00919 typeflag(x) = (T_VECTOR | T_ATOM);
00920 ivalue_unchecked(x)=len;
00921 set_integer(x);
00922 fill_vector(x,sc->NIL);
00923 return x;
00924 }
00925
00926 INTERFACE static void fill_vector(pointer vec, pointer obj) {
00927 int i;
00928 int num=ivalue(vec)/2+ivalue(vec)%2;
00929 for(i=0; i<num; i++) {
00930 typeflag(vec+1+i) = T_PAIR;
00931 setimmutable(vec+1+i);
00932 car(vec+1+i)=obj;
00933 cdr(vec+1+i)=obj;
00934 }
00935 }
00936
00937 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
00938 int n=ielem/2;
00939 if(ielem%2==0) {
00940 return car(vec+1+n);
00941 } else {
00942 return cdr(vec+1+n);
00943 }
00944 }
00945
00946 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
00947 int n=ielem/2;
00948 if(ielem%2==0) {
00949 return car(vec+1+n)=a;
00950 } else {
00951 return cdr(vec+1+n)=a;
00952 }
00953 }
00954
00955
00956 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
00957 pointer x;
00958
00959
00960 x = oblist_find_by_name(sc, name);
00961 if (x != sc->NIL) {
00962 return (x);
00963 } else {
00964 x = oblist_add_by_name(sc, name);
00965 return (x);
00966 }
00967 }
00968
00969 INTERFACE pointer gensym(scheme *sc) {
00970 pointer x;
00971 char name[40];
00972
00973 for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
00974 sprintf(name,"gensym-%ld",sc->gensym_cnt);
00975
00976
00977 x = oblist_find_by_name(sc, name);
00978
00979 if (x != sc->NIL) {
00980 continue;
00981 } else {
00982 x = oblist_add_by_name(sc, name);
00983 return (x);
00984 }
00985 }
00986
00987 return sc->NIL;
00988 }
00989
00990
00991 static pointer mk_atom(scheme *sc, char *q) {
00992 char c, *p;
00993 int has_dec_point=0;
00994 int has_fp_exp = 0;
00995
00996 #if USE_COLON_HOOK
00997 if((p=strstr(q,"::"))!=0) {
00998 *p=0;
00999 return cons(sc, sc->COLON_HOOK,
01000 cons(sc,
01001 cons(sc,
01002 sc->QUOTE,
01003 cons(sc, mk_atom(sc,p+2), sc->NIL)),
01004 cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
01005 }
01006 #endif
01007
01008 p = q;
01009 c = *p++;
01010 if ((c == '+') || (c == '-')) {
01011 c = *p++;
01012 if (c == '.') {
01013 has_dec_point=1;
01014 c = *p++;
01015 }
01016 if (!isdigit((int) c)) {
01017 return (mk_symbol(sc, strlwr(q)));
01018 }
01019 } else if (c == '.') {
01020 has_dec_point=1;
01021 c = *p++;
01022 if (!isdigit((int) c)) {
01023 return (mk_symbol(sc, strlwr(q)));
01024 }
01025 } else if (!isdigit((int) c)) {
01026 return (mk_symbol(sc, strlwr(q)));
01027 }
01028
01029 for ( ; (c = *p) != 0; ++p) {
01030 if (!isdigit((int) c)) {
01031 if(c=='.') {
01032 if(!has_dec_point) {
01033 has_dec_point=1;
01034 continue;
01035 }
01036 }
01037 else if ((c == 'e') || (c == 'E')) {
01038 if(!has_fp_exp) {
01039 has_dec_point = 1;
01040
01041 p++;
01042 if ((*p == '-') || (*p == '+') || isdigit((int) *p)) {
01043 continue;
01044 }
01045 }
01046 }
01047 return (mk_symbol(sc, strlwr(q)));
01048 }
01049 }
01050 if(has_dec_point) {
01051 return mk_real(sc,atof(q));
01052 }
01053 return (mk_integer(sc, atol(q)));
01054 }
01055
01056
01057 static pointer mk_sharp_const(scheme *sc, char *name) {
01058 long x;
01059 char tmp[256];
01060
01061 if (!strcmp(name, "t"))
01062 return (sc->T);
01063 else if (!strcmp(name, "f"))
01064 return (sc->F);
01065 else if (*name == 'o') {
01066 sprintf(tmp, "0%s", name+1);
01067 sscanf(tmp, "%lo", &x);
01068 return (mk_integer(sc, x));
01069 } else if (*name == 'd') {
01070 sscanf(name+1, "%ld", &x);
01071 return (mk_integer(sc, x));
01072 } else if (*name == 'x') {
01073 sprintf(tmp, "0x%s", name+1);
01074 sscanf(tmp, "%lx", &x);
01075 return (mk_integer(sc, x));
01076 } else if (*name == 'b') {
01077 x = binary_decode(name+1);
01078 return (mk_integer(sc, x));
01079 } else if (*name == '\\') {
01080 int c=0;
01081 if(stricmp(name+1,"space")==0) {
01082 c=' ';
01083 } else if(stricmp(name+1,"newline")==0) {
01084 c='\n';
01085 } else if(stricmp(name+1,"return")==0) {
01086 c='\r';
01087 } else if(stricmp(name+1,"tab")==0) {
01088 c='\t';
01089 } else if(name[1]=='x' && name[2]!=0) {
01090 int c1=0;
01091 if(sscanf(name+2,"%x",&c1)==1 && c1<256) {
01092 c=c1;
01093 } else {
01094 return sc->NIL;
01095 }
01096 #if USE_ASCII_NAMES
01097 } else if(is_ascii_name(name+1,&c)) {
01098
01099 #endif
01100 } else if(name[2]==0) {
01101 c=name[1];
01102 } else {
01103 return sc->NIL;
01104 }
01105 return mk_character(sc,c);
01106 } else
01107 return (sc->NIL);
01108 }
01109
01110
01111
01112
01113
01114
01115
01116
01117 static void mark(pointer a) {
01118 pointer t, q, p;
01119
01120 t = (pointer) 0;
01121 p = a;
01122 E2: setmark(p);
01123 if(is_vector(p)) {
01124 int i;
01125 int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
01126 for(i=0; i<num; i++) {
01127
01128 mark(p+1+i);
01129 }
01130 }
01131 if (is_atom(p))
01132 goto E6;
01133
01134 q = car(p);
01135 if (q && !is_mark(q)) {
01136 setatom(p);
01137 car(p) = t;
01138 t = p;
01139 p = q;
01140 goto E2;
01141 }
01142 E5: q = cdr(p);
01143 if (q && !is_mark(q)) {
01144 cdr(p) = t;
01145 t = p;
01146 p = q;
01147 goto E2;
01148 }
01149 E6:
01150 if (!t)
01151 return;
01152 q = t;
01153 if (is_atom(q)) {
01154 clratom(q);
01155 t = car(q);
01156 car(q) = p;
01157 p = q;
01158 goto E5;
01159 } else {
01160 t = cdr(q);
01161 cdr(q) = p;
01162 p = q;
01163 goto E6;
01164 }
01165 }
01166
01167
01168 static void gc(scheme *sc, pointer a, pointer b) {
01169 pointer p;
01170 int i;
01171
01172 if(sc->gc_verbose) {
01173 putstr(sc, "gc...");
01174 }
01175
01176
01177 mark(sc->oblist);
01178 mark(sc->global_env);
01179
01180
01181 mark(sc->args);
01182 mark(sc->envir);
01183 mark(sc->code);
01184 dump_stack_mark(sc);
01185 mark(sc->value);
01186 mark(sc->inport);
01187 mark(sc->save_inport);
01188 mark(sc->outport);
01189 mark(sc->loadport);
01190
01191
01192 mark(a);
01193 mark(b);
01194
01195
01196 clrmark(sc->NIL);
01197 sc->fcells = 0;
01198 sc->free_cell = sc->NIL;
01199
01200
01201
01202
01203
01204 for (i = sc->last_cell_seg; i >= 0; i--) {
01205 p = sc->cell_seg[i] + CELL_SEGSIZE;
01206 while (--p >= sc->cell_seg[i]) {
01207 if (is_mark(p)) {
01208 clrmark(p);
01209 } else {
01210
01211 if (typeflag(p) != 0) {
01212 finalize_cell(sc, p);
01213 typeflag(p) = 0;
01214 car(p) = sc->NIL;
01215 }
01216 ++sc->fcells;
01217 cdr(p) = sc->free_cell;
01218 sc->free_cell = p;
01219 }
01220 }
01221 }
01222
01223 if (sc->gc_verbose) {
01224 char msg[80];
01225 sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells);
01226 putstr(sc,msg);
01227 }
01228 }
01229
01230 static void finalize_cell(scheme *sc, pointer a) {
01231 if(is_string(a)) {
01232 sc->free(strvalue(a));
01233 } else if(is_port(a)) {
01234 if(a->_object._port->kind&port_file
01235 && a->_object._port->rep.stdio.closeit) {
01236 port_close(sc,a,port_input|port_output);
01237 }
01238 sc->free(a->_object._port);
01239 }
01240 }
01241
01242
01243
01244 static int file_push(scheme *sc, const char *fname) {
01245 FILE *fin=fopen(fname,"r");
01246 if(fin!=0) {
01247 sc->file_i++;
01248 sc->load_stack[sc->file_i].kind=port_file|port_input;
01249 sc->load_stack[sc->file_i].rep.stdio.file=fin;
01250 sc->load_stack[sc->file_i].rep.stdio.closeit=1;
01251 sc->nesting_stack[sc->file_i]=0;
01252 sc->loadport->_object._port=sc->load_stack+sc->file_i;
01253 }
01254 return fin!=0;
01255 }
01256
01257 static void file_pop(scheme *sc) {
01258 sc->nesting=sc->nesting_stack[sc->file_i];
01259 if(sc->file_i!=0) {
01260 port_close(sc,sc->loadport,port_input);
01261 sc->file_i--;
01262 sc->loadport->_object._port=sc->load_stack+sc->file_i;
01263 if(file_interactive(sc)) {
01264 putstr(sc,prompt);
01265 }
01266 }
01267 }
01268
01269 static int file_interactive(scheme *sc) {
01270 return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
01271 && sc->inport->_object._port->kind&port_file;
01272 }
01273
01274 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
01275 FILE *f;
01276 char *rw;
01277 port *pt;
01278 if(prop==(port_input|port_output)) {
01279 rw="a+";
01280 } else if(prop==port_output) {
01281 rw="w";
01282 } else {
01283 rw="r";
01284 }
01285 f=fopen(fn,rw);
01286 if(f==0) {
01287 return 0;
01288 }
01289 pt=port_rep_from_file(sc,f,prop);
01290 pt->rep.stdio.closeit=1;
01291 return pt;
01292 }
01293
01294 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
01295 port *pt;
01296 pt=port_rep_from_filename(sc,fn,prop);
01297 if(pt==0) {
01298 return sc->NIL;
01299 }
01300 return mk_port(sc,pt);
01301 }
01302
01303 static port *port_rep_from_file(scheme *sc, FILE *f, int prop) {
01304 char *rw;
01305 port *pt;
01306 pt=(port*)sc->malloc(sizeof(port));
01307 if(pt==0) {
01308 return 0;
01309 }
01310 if(prop==(port_input|port_output)) {
01311 rw="a+";
01312 } else if(prop==port_output) {
01313 rw="w";
01314 } else {
01315 rw="r";
01316 }
01317 pt->kind=port_file|prop;
01318 pt->rep.stdio.file=f;
01319 pt->rep.stdio.closeit=0;
01320 return pt;
01321 }
01322
01323 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
01324 port *pt;
01325 pt=port_rep_from_file(sc,f,prop);
01326 if(pt==0) {
01327 return sc->NIL;
01328 }
01329 return mk_port(sc,pt);
01330 }
01331
01332 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
01333 port *pt;
01334 pt=(port*)sc->malloc(sizeof(port));
01335 if(pt==0) {
01336 return 0;
01337 }
01338 pt->kind=port_string|prop;
01339 pt->rep.string.start=start;
01340 pt->rep.string.curr=start;
01341 pt->rep.string.past_the_end=past_the_end;
01342 return pt;
01343 }
01344
01345 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
01346 port *pt;
01347 pt=port_rep_from_string(sc,start,past_the_end,prop);
01348 if(pt==0) {
01349 return sc->NIL;
01350 }
01351 return mk_port(sc,pt);
01352 }
01353
01354 static void port_close(scheme *sc, pointer p, int flag) {
01355 port *pt=p->_object._port;
01356 pt->kind&=~flag;
01357 if((pt->kind & (port_input|port_output))==0) {
01358 if(pt->kind&port_file) {
01359 fclose(pt->rep.stdio.file);
01360 }
01361 pt->kind=port_free;
01362 }
01363 }
01364
01365
01366 static int inchar(scheme *sc) {
01367 int c;
01368 port *pt;
01369 again:
01370 pt=sc->inport->_object._port;
01371 c=basic_inchar(pt);
01372 if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {
01373 file_pop(sc);
01374 if(sc->nesting!=0) {
01375 return EOF;
01376 }
01377 goto again;
01378 }
01379 return c;
01380 }
01381
01382 static int basic_inchar(port *pt) {
01383 if(pt->kind&port_file) {
01384 return fgetc(pt->rep.stdio.file);
01385 } else {
01386 if(*pt->rep.string.curr==0
01387 || pt->rep.string.curr==pt->rep.string.past_the_end) {
01388 return EOF;
01389 } else {
01390 return *pt->rep.string.curr++;
01391 }
01392 }
01393 }
01394
01395
01396 static void backchar(scheme *sc, int c) {
01397 port *pt;
01398 if(c==EOF) return;
01399 pt=sc->inport->_object._port;
01400 if(pt->kind&port_file) {
01401 ungetc(c,pt->rep.stdio.file);
01402 } else {
01403 if(pt->rep.string.curr!=pt->rep.string.start) {
01404 --pt->rep.string.curr;
01405 }
01406 }
01407 }
01408
01409 INTERFACE void putstr(scheme *sc, const char *s) {
01410 port *pt=sc->outport->_object._port;
01411 if(pt->kind&port_file) {
01412 fputs(s,pt->rep.stdio.file);
01413 } else {
01414 for(;*s;s++) {
01415 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01416 *pt->rep.string.curr++=*s;
01417 }
01418 }
01419 }
01420 }
01421
01422 static void putchars(scheme *sc, const char *s, int len) {
01423 port *pt=sc->outport->_object._port;
01424 if(pt->kind&port_file) {
01425 fwrite(s,1,len,pt->rep.stdio.file);
01426 } else {
01427 for(;len;len--) {
01428 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01429 *pt->rep.string.curr++=*s++;
01430 }
01431 }
01432 }
01433 }
01434
01435 INTERFACE void putcharacter(scheme *sc, int c) {
01436 port *pt=sc->outport->_object._port;
01437 if(pt->kind&port_file) {
01438 fputc(c,pt->rep.stdio.file);
01439 } else {
01440 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01441 *pt->rep.string.curr++=c;
01442 }
01443 }
01444 }
01445
01446
01447 static char *readstr_upto(scheme *sc, char *delim) {
01448 char *p = sc->strbuff;
01449
01450 while (!is_one_of(delim, (*p++ = inchar(sc))));
01451 if(p==sc->strbuff+2 && p[-2]=='\\') {
01452 *p=0;
01453 } else {
01454 backchar(sc,p[-1]);
01455 *--p = '\0';
01456 }
01457 return sc->strbuff;
01458 }
01459
01460
01461 static pointer readstrexp(scheme *sc) {
01462 char *p = sc->strbuff;
01463 int c;
01464 int c1=0;
01465 enum { st_ok, st_bsl, st_x1, st_x2} state=st_ok;
01466
01467 for (;;) {
01468 c=inchar(sc);
01469 if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) {
01470 return sc->F;
01471 }
01472 switch(state) {
01473 case st_ok:
01474 switch(c) {
01475 case '\\':
01476 state=st_bsl;
01477 break;
01478 case '"':
01479 *p=0;
01480 return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
01481 default:
01482 *p++=c;
01483 break;
01484 }
01485 break;
01486 case st_bsl:
01487 switch(c) {
01488 case 'x':
01489 case 'X':
01490 state=st_x1;
01491 c1=0;
01492 break;
01493 case 'n':
01494 *p++='\n';
01495 state=st_ok;
01496 break;
01497 case 't':
01498 *p++='\t';
01499 state=st_ok;
01500 break;
01501 case 'r':
01502 *p++='\r';
01503 state=st_ok;
01504 break;
01505 case '"':
01506 *p++='"';
01507 state=st_ok;
01508 break;
01509 default:
01510 *p++=c;
01511 state=st_ok;
01512 break;
01513 }
01514 break;
01515 case st_x1:
01516 case st_x2:
01517 c=toupper(c);
01518 if(c>='0' && c<='F') {
01519 if(c<='9') {
01520 c1=(c1<<4)+c-'0';
01521 } else {
01522 c1=(c1<<4)+c-'A'+10;
01523 }
01524 if(state==st_x1) {
01525 state=st_x2;
01526 } else {
01527 *p++=c1;
01528 state=st_ok;
01529 }
01530 } else {
01531 return sc->F;
01532 }
01533 break;
01534 }
01535 }
01536 }
01537
01538
01539 static INLINE int is_one_of(char *s, int c) {
01540 if(c==EOF) return 1;
01541 while (*s)
01542 if (*s++ == c)
01543 return (1);
01544 return (0);
01545 }
01546
01547
01548 static INLINE void skipspace(scheme *sc) {
01549 int c;
01550 while (isspace(c=inchar(sc)))
01551 ;
01552 if(c!=EOF) {
01553 backchar(sc,c);
01554 }
01555 }
01556
01557
01558 static int token(scheme *sc) {
01559 int c;
01560 skipspace(sc);
01561 switch (c=inchar(sc)) {
01562 case EOF:
01563 return (TOK_EOF);
01564 case '(':
01565 return (TOK_LPAREN);
01566 case ')':
01567 return (TOK_RPAREN);
01568 case '.':
01569 c=inchar(sc);
01570 if(is_one_of(" \n\t",c)) {
01571 return (TOK_DOT);
01572 } else {
01573 backchar(sc,c);
01574 backchar(sc,'.');
01575 return TOK_ATOM;
01576 }
01577 case '\'':
01578 return (TOK_QUOTE);
01579 case ';':
01580 return (TOK_COMMENT);
01581 case '"':
01582 return (TOK_DQUOTE);
01583 case BACKQUOTE:
01584 return (TOK_BQUOTE);
01585 case ',':
01586 if ((c=inchar(sc)) == '@')
01587 return (TOK_ATMARK);
01588 else {
01589 backchar(sc,c);
01590 return (TOK_COMMA);
01591 }
01592 case '#':
01593 c=inchar(sc);
01594 if (c == '(') {
01595 return (TOK_VEC);
01596 } else if(c == '!') {
01597 return TOK_COMMENT;
01598 } else {
01599 backchar(sc,c);
01600 if(is_one_of(" tfodxb\\",c)) {
01601 return TOK_SHARP_CONST;
01602 } else {
01603 return (TOK_SHARP);
01604 }
01605 }
01606 default:
01607 backchar(sc,c);
01608 return (TOK_ATOM);
01609 }
01610 }
01611
01612
01613 #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
01614
01615 static void printslashstring(scheme *sc, char *p, int len) {
01616 int i;
01617 unsigned char *s=(unsigned char*)p;
01618 putcharacter(sc,'"');
01619 for ( i=0; i<len; i++) {
01620 if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
01621 putcharacter(sc,'\\');
01622 switch(*s) {
01623 case '"':
01624 putcharacter(sc,'"');
01625 break;
01626 case '\n':
01627 putcharacter(sc,'n');
01628 break;
01629 case '\t':
01630 putcharacter(sc,'t');
01631 break;
01632 case '\r':
01633 putcharacter(sc,'r');
01634 break;
01635 case '\\':
01636 putcharacter(sc,'\\');
01637 break;
01638 default: {
01639 int d=*s/16;
01640 putcharacter(sc,'x');
01641 if(d<10) {
01642 putcharacter(sc,d+'0');
01643 } else {
01644 putcharacter(sc,d-10+'A');
01645 }
01646 d=*s%16;
01647 if(d<10) {
01648 putcharacter(sc,d+'0');
01649 } else {
01650 putcharacter(sc,d-10+'A');
01651 }
01652 }
01653 }
01654 } else {
01655 putcharacter(sc,*s);
01656 }
01657 s++;
01658 }
01659 putcharacter(sc,'"');
01660 }
01661
01662
01663
01664 static void printatom(scheme *sc, pointer l, int f) {
01665 char *p;
01666 int len;
01667 atom2str(sc,l,f,&p,&len);
01668 putchars(sc,p,len);
01669 }
01670
01671
01672
01673 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
01674 char *p;
01675
01676 if (l == sc->NIL) {
01677 p = "()";
01678 } else if (l == sc->T) {
01679 p = "#t";
01680 } else if (l == sc->F) {
01681 p = "#f";
01682 } else if (l == sc->EOF_OBJ) {
01683 p = "#<EOF>";
01684 } else if (is_port(l)) {
01685 p = sc->strbuff;
01686 strcpy(p, "#<PORT>");
01687 } else if (is_number(l)) {
01688 p = sc->strbuff;
01689 if(is_integer(l)) {
01690 sprintf(p, "%ld", ivalue_unchecked(l));
01691 } else {
01692 sprintf(p, "%.10g", rvalue_unchecked(l));
01693 }
01694 } else if (is_string(l)) {
01695 if (!f) {
01696 p = strvalue(l);
01697 } else {
01698 *pp=sc->strbuff;
01699 *plen=0;
01700 printslashstring(sc, strvalue(l), strlength(l));
01701 return;
01702 }
01703 } else if (is_character(l)) {
01704 int c=charvalue(l);
01705 p = sc->strbuff;
01706 if (!f) {
01707 p[0]=c;
01708 p[1]=0;
01709 } else {
01710 switch(c) {
01711 case ' ':
01712 sprintf(p,"#\\space"); break;
01713 case '\n':
01714 sprintf(p,"#\\newline"); break;
01715 case '\r':
01716 sprintf(p,"#\\return"); break;
01717 case '\t':
01718 sprintf(p,"#\\tab"); break;
01719 default:
01720 #if USE_ASCII_NAMES
01721 if(c==127) {
01722 strcpy(p,"#\\del"); break;
01723 } else if(c<32) {
01724 strcpy(p,"#\\"); strcat(p,charnames[c]); break;
01725 }
01726 #else
01727 if(c<32) {
01728 sprintf(p,"#\\x%x",c); break;
01729 }
01730 #endif
01731 sprintf(p,"#\\%c",c); break;
01732 }
01733 }
01734 } else if (is_symbol(l)) {
01735 p = symname(l);
01736 } else if (is_proc(l)) {
01737 p = sc->strbuff;
01738 sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l));
01739 } else if (is_macro(l)) {
01740 p = "#<MACRO>";
01741 } else if (is_closure(l)) {
01742 p = "#<CLOSURE>";
01743 } else if (is_promise(l)) {
01744 p = "#<PROMISE>";
01745 } else if (is_foreign(l)) {
01746 p = sc->strbuff;
01747 sprintf(p, "#<FOREIGN PROCEDURE %ld>", procnum(l));
01748 } else if (is_continuation(l)) {
01749 p = "#<CONTINUATION>";
01750 } else {
01751 p = "#<ERROR>";
01752 }
01753 *pp=p;
01754 *plen=strlen(p);
01755 }
01756
01757
01758
01759 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
01760 pointer x = get_cell(sc, c, e);
01761
01762 typeflag(x) = T_CLOSURE;
01763 car(x) = c;
01764 cdr(x) = e;
01765 return (x);
01766 }
01767
01768
01769 static pointer mk_continuation(scheme *sc, pointer d) {
01770 pointer x = get_cell(sc, sc->NIL, d);
01771
01772 typeflag(x) = T_CONTINUATION;
01773 cont_dump(x) = d;
01774 return (x);
01775 }
01776
01777 static pointer list_star(scheme *sc, pointer d) {
01778 pointer p, q;
01779 if(cdr(d)==sc->NIL) {
01780 return car(d);
01781 }
01782 p=cons(sc,car(d),cdr(d));
01783 q=p;
01784 while(cdr(cdr(p))!=sc->NIL) {
01785 d=cons(sc,car(p),cdr(p));
01786 if(cdr(cdr(p))!=sc->NIL) {
01787 p=cdr(d);
01788 }
01789 }
01790 cdr(p)=car(cdr(p));
01791 return q;
01792 }
01793
01794
01795 static pointer reverse(scheme *sc, pointer a) {
01796
01797 pointer p = sc->NIL;
01798
01799 for ( ; is_pair(a); a = cdr(a)) {
01800 p = cons(sc, car(a), p);
01801 }
01802 return (p);
01803 }
01804
01805
01806 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
01807 pointer p = list, result = term, q;
01808
01809 while (p != sc->NIL) {
01810 q = cdr(p);
01811 cdr(p) = result;
01812 result = p;
01813 p = q;
01814 }
01815 return (result);
01816 }
01817
01818
01819 static pointer append(scheme *sc, pointer a, pointer b) {
01820 pointer p = b, q;
01821
01822 if (a != sc->NIL) {
01823 a = reverse(sc, a);
01824 while (a != sc->NIL) {
01825 q = cdr(a);
01826 cdr(a) = p;
01827 p = a;
01828 a = q;
01829 }
01830 }
01831 return (p);
01832 }
01833
01834
01835 static int eqv(pointer a, pointer b) {
01836 if (is_string(a)) {
01837 if (is_string(b))
01838 return (strvalue(a) == strvalue(b));
01839 else
01840 return (0);
01841 } else if (is_number(a)) {
01842 if (is_number(b))
01843 return num_eq(nvalue(a),nvalue(b));
01844 else
01845 return (0);
01846 } else if (is_character(a)) {
01847 if (is_character(b))
01848 return charvalue(a)==charvalue(b);
01849 else
01850 return (0);
01851 } else if (is_port(a)) {
01852 if (is_port(b))
01853 return a==b;
01854 else
01855 return (0);
01856 } else if (is_proc(a)) {
01857 if (is_proc(b))
01858 return procnum(a)==procnum(b);
01859 else
01860 return (0);
01861 } else {
01862 return (a == b);
01863 }
01864 }
01865
01866
01867
01868 #define is_true(p) ((p) != sc->F)
01869 #define is_false(p) ((p) == sc->F)
01870
01871
01872
01873 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
01874
01875 static int hash_fn(const char *key, int table_size)
01876 {
01877 unsigned int hashed = 0;
01878 const char *c;
01879 int bits_per_int = sizeof(unsigned int)*8;
01880
01881 for (c = key; *c; c++) {
01882
01883 hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
01884 hashed ^= *c;
01885 }
01886 return hashed % table_size;
01887 }
01888 #endif
01889
01890 #ifndef USE_ALIST_ENV
01891
01892
01893
01894
01895
01896
01897
01898
01899
01900 static void new_frame_in_env(scheme *sc, pointer old_env)
01901 {
01902 pointer new_frame;
01903
01904
01905 if (old_env == sc->NIL) {
01906 new_frame = mk_vector(sc, 461);
01907 } else {
01908 new_frame = sc->NIL;
01909 }
01910
01911 sc->envir = immutable_cons(sc, new_frame, old_env);
01912 setenvironment(sc->envir);
01913 }
01914
01915 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
01916 pointer variable, pointer value)
01917 {
01918 pointer slot = immutable_cons(sc, variable, value);
01919
01920 if (is_vector(car(env))) {
01921 int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
01922
01923 set_vector_elem(car(env), location,
01924 immutable_cons(sc, slot, vector_elem(car(env), location)));
01925 } else {
01926 car(env) = immutable_cons(sc, slot, car(env));
01927 }
01928 }
01929
01930 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
01931 {
01932 pointer x = sc->NIL, y = sc->NIL;
01933 int location = 0;
01934
01935 for (x = env; x != sc->NIL; x = cdr(x)) {
01936 if (is_vector(car(x))) {
01937 location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
01938 y = vector_elem(car(x), location);
01939 } else {
01940 y = car(x);
01941 }
01942 for ( ; y != sc->NIL; y = cdr(y)) {
01943 if (caar(y) == hdl) {
01944 break;
01945 }
01946 }
01947 if (y != sc->NIL) {
01948 break;
01949 }
01950 if(!all) {
01951 return sc->NIL;
01952 }
01953 }
01954 if (x != sc->NIL) {
01955 return car(y);
01956 }
01957 return sc->NIL;
01958 }
01959
01960 #else
01961
01962 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
01963 {
01964 sc->envir = immutable_cons(sc, sc->NIL, old_env);
01965 setenvironment(sc->envir);
01966 }
01967
01968 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
01969 pointer variable, pointer value)
01970 {
01971 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
01972 }
01973
01974 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
01975 {
01976 pointer x,y;
01977 for (x = env; x != sc->NIL; x = cdr(x)) {
01978 for (y = car(x); y != sc->NIL; y = cdr(y)) {
01979 if (caar(y) == hdl) {
01980 break;
01981 }
01982 }
01983 if (y != sc->NIL) {
01984 break;
01985 }
01986 if(!all) {
01987 return sc->NIL;
01988 }
01989 }
01990 if (x != sc->NIL) {
01991 return car(y);
01992 }
01993 return sc->NIL;
01994 }
01995
01996 #endif
01997
01998 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
01999 {
02000 new_slot_spec_in_env(sc, sc->envir, variable, value);
02001 }
02002
02003 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
02004 {
02005 cdr(slot) = value;
02006 }
02007
02008 static INLINE pointer slot_value_in_env(pointer slot)
02009 {
02010 return cdr(slot);
02011 }
02012
02013
02014
02015
02016 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
02017 #if USE_ERROR_HOOK
02018 pointer x;
02019 pointer hdl=sc->ERROR_HOOK;
02020
02021 x=find_slot_in_env(sc,sc->envir,hdl,1);
02022 if (x != sc->NIL) {
02023 if(a!=0) {
02024 sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
02025 } else {
02026 sc->code = sc->NIL;
02027 }
02028 sc->code = cons(sc, mk_string(sc, (s)), sc->code);
02029 setimmutable(car(sc->code));
02030 sc->code = cons(sc, slot_value_in_env(x), sc->code);
02031 sc->op = (int)OP_EVAL;
02032 return sc->T;
02033 }
02034 #endif
02035
02036 if(a!=0) {
02037 sc->args = cons(sc, (a), sc->NIL);
02038 } else {
02039 sc->args = sc->NIL;
02040 }
02041 sc->args = cons(sc, mk_string(sc, (s)), sc->args);
02042 setimmutable(car(sc->args));
02043 sc->op = (int)OP_ERR0;
02044 return sc->T;
02045 }
02046 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
02047 #define Error_0(sc,s) return _Error_1(sc,s,0)
02048
02049
02050 # define BEGIN do {
02051 # define END } while (0)
02052 #define s_goto(sc,a) BEGIN \
02053 sc->op = (int)(a); \
02054 return sc->T; END
02055
02056 #define s_return(sc,a) return _s_return(sc,a)
02057
02058 #ifndef USE_SCHEME_STACK
02059
02060
02061 struct dump_stack_frame {
02062 enum scheme_opcodes op;
02063 pointer args;
02064 pointer envir;
02065 pointer code;
02066 };
02067
02068 #define STACK_GROWTH 3
02069
02070 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
02071 {
02072 long nframes = (long)sc->dump;
02073 struct dump_stack_frame *next_frame;
02074
02075
02076 if (nframes >= sc->dump_size) {
02077 sc->dump_size += STACK_GROWTH;
02078
02079 sc->dump_base = realloc(sc->dump_base,
02080 sizeof(struct dump_stack_frame) * sc->dump_size);
02081 }
02082 next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
02083 next_frame->op = op;
02084 next_frame->args = args;
02085 next_frame->envir = sc->envir;
02086 next_frame->code = code;
02087 sc->dump = (pointer)(nframes+1L);
02088 }
02089
02090 static pointer _s_return(scheme *sc, pointer a)
02091 {
02092 long nframes = (long)sc->dump;
02093 struct dump_stack_frame *frame;
02094
02095 sc->value = (a);
02096 if (nframes <= 0) {
02097 return sc->NIL;
02098 }
02099 nframes--;
02100 frame = (struct dump_stack_frame *)sc->dump_base + nframes;
02101 sc->op = frame->op;
02102 sc->args = frame->args;
02103 sc->envir = frame->envir;
02104 sc->code = frame->code;
02105 sc->dump = (pointer)nframes;
02106 return sc->T;
02107 }
02108
02109 static INLINE void dump_stack_reset(scheme *sc)
02110 {
02111
02112 sc->dump = (pointer)0;
02113 }
02114
02115 static INLINE void dump_stack_initialize(scheme *sc)
02116 {
02117 sc->dump_size = 0;
02118 sc->dump_base = NULL;
02119 dump_stack_reset(sc);
02120 }
02121
02122 static void dump_stack_free(scheme *sc)
02123 {
02124 free(sc->dump_base);
02125 sc->dump_base = NULL;
02126 sc->dump = (pointer)0;
02127 sc->dump_size = 0;
02128 }
02129
02130 static INLINE void dump_stack_mark(scheme *sc)
02131 {
02132 long nframes = (long)sc->dump;
02133 int i;
02134 for(i=0; i<nframes; i++) {
02135 struct dump_stack_frame *frame;
02136 frame = (struct dump_stack_frame *)sc->dump_base + i;
02137 mark(frame->args);
02138 mark(frame->envir);
02139 mark(frame->code);
02140 }
02141 }
02142
02143 #else
02144
02145 static INLINE void dump_stack_reset(scheme *sc)
02146 {
02147 sc->dump = sc->NIL;
02148 }
02149
02150 static INLINE void dump_stack_initialize(scheme *sc)
02151 {
02152 dump_stack_reset(sc);
02153 }
02154
02155 static void dump_stack_free(scheme *sc)
02156 {
02157 sc->dump = sc->NIL;
02158 }
02159
02160 static pointer _s_return(scheme *sc, pointer a) {
02161 sc->value = (a);
02162 if(sc->dump==sc->NIL) return sc->NIL;
02163 sc->op = ivalue(car(sc->dump));
02164 sc->args = cadr(sc->dump);
02165 sc->envir = caddr(sc->dump);
02166 sc->code = cadddr(sc->dump);
02167 sc->dump = cddddr(sc->dump);
02168 return sc->T;
02169 }
02170
02171 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
02172 sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
02173 sc->dump = cons(sc, (args), sc->dump);
02174 sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
02175 }
02176
02177 static INLINE void dump_stack_mark(scheme *sc)
02178 {
02179 mark(sc->dump);
02180 }
02181 #endif
02182
02183 #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
02184
02185 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
02186 pointer x, y;
02187
02188 switch (op) {
02189 case OP_LOAD:
02190 if(file_interactive(sc)) {
02191 fprintf(sc->outport->_object._port->rep.stdio.file,
02192 "Loading %s\n", strvalue(car(sc->args)));
02193 }
02194 if (!file_push(sc,strvalue(car(sc->args)))) {
02195 Error_1(sc,"unable to open", car(sc->args));
02196 }
02197 s_goto(sc,OP_T0LVL);
02198
02199 case OP_T0LVL:
02200 if(file_interactive(sc)) {
02201 putstr(sc,"\n");
02202 }
02203 sc->nesting=0;
02204 dump_stack_reset(sc);
02205 sc->envir = sc->global_env;
02206 sc->save_inport=sc->inport;
02207 sc->inport = sc->loadport;
02208 s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
02209 s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
02210 s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
02211 if (file_interactive(sc)) {
02212 putstr(sc,prompt);
02213 }
02214 s_goto(sc,OP_READ_INTERNAL);
02215
02216 case OP_T1LVL:
02217 sc->code = sc->value;
02218 sc->inport=sc->save_inport;
02219 s_goto(sc,OP_EVAL);
02220
02221 case OP_READ_INTERNAL:
02222 sc->tok = token(sc);
02223 if(sc->tok==TOK_EOF) {
02224 if(sc->inport==sc->loadport) {
02225 sc->args=sc->NIL;
02226 s_goto(sc,OP_QUIT);
02227 } else {
02228 s_return(sc,sc->EOF_OBJ);
02229 }
02230 }
02231 s_goto(sc,OP_RDSEXPR);
02232
02233 case OP_GENSYM:
02234 s_return(sc, gensym(sc));
02235
02236 case OP_VALUEPRINT:
02237
02238
02239
02240 if(sc->tracing) {
02241 putstr(sc,"\nGives: ");
02242 }
02243 if(file_interactive(sc)) {
02244 sc->print_flag = 1;
02245 sc->args = sc->value;
02246 s_goto(sc,OP_P0LIST);
02247 } else {
02248 s_return(sc,sc->value);
02249 }
02250
02251 case OP_EVAL:
02252 #if USE_TRACING
02253 if(sc->tracing) {
02254
02255 s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
02256 sc->args=sc->code;
02257 putstr(sc,"\nEval: ");
02258 s_goto(sc,OP_P0LIST);
02259 }
02260
02261 case OP_REAL_EVAL:
02262 #endif
02263 if (is_symbol(sc->code)) {
02264 x=find_slot_in_env(sc,sc->envir,sc->code,1);
02265 if (x != sc->NIL) {
02266 s_return(sc,slot_value_in_env(x));
02267 } else {
02268 Error_1(sc,"eval: unbound variable:", sc->code);
02269 }
02270 } else if (is_pair(sc->code)) {
02271 if (is_syntax(x = car(sc->code))) {
02272 sc->code = cdr(sc->code);
02273 s_goto(sc,syntaxnum(x));
02274 } else {
02275 s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
02276
02277 sc->code = car(sc->code);
02278 s_goto(sc,OP_EVAL);
02279 }
02280 } else {
02281 s_return(sc,sc->code);
02282 }
02283
02284 case OP_E0ARGS:
02285 if (is_macro(sc->value)) {
02286 s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
02287 sc->args = cons(sc,sc->code, sc->NIL);
02288 sc->code = sc->value;
02289 s_goto(sc,OP_APPLY);
02290 } else {
02291 sc->code = cdr(sc->code);
02292 s_goto(sc,OP_E1ARGS);
02293 }
02294
02295 case OP_E1ARGS:
02296 sc->args = cons(sc, sc->value, sc->args);
02297 if (is_pair(sc->code)) {
02298 s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
02299 sc->code = car(sc->code);
02300 sc->args = sc->NIL;
02301 s_goto(sc,OP_EVAL);
02302 } else {
02303 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02304 sc->code = car(sc->args);
02305 sc->args = cdr(sc->args);
02306 s_goto(sc,OP_APPLY);
02307 }
02308
02309 #if USE_TRACING
02310 case OP_TRACING: {
02311 int tr=sc->tracing;
02312 sc->tracing=ivalue(car(sc->args));
02313 s_return(sc,mk_integer(sc,tr));
02314 }
02315 #endif
02316
02317 case OP_APPLY:
02318 #if USE_TRACING
02319 if(sc->tracing) {
02320 s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
02321 sc->print_flag = 1;
02322
02323 putstr(sc,"\nApply to: ");
02324 s_goto(sc,OP_P0LIST);
02325 }
02326
02327 case OP_REAL_APPLY:
02328 #endif
02329 if (is_proc(sc->code)) {
02330 s_goto(sc,procnum(sc->code));
02331 } else if (is_foreign(sc->code)) {
02332 x=sc->code->_object._ff(sc,sc->args);
02333 s_return(sc,x);
02334 } else if (is_closure(sc->code) || is_macro(sc->code)
02335 || is_promise(sc->code)) {
02336
02337
02338 new_frame_in_env(sc, closure_env(sc->code));
02339 for (x = car(closure_code(sc->code)), y = sc->args;
02340 is_pair(x); x = cdr(x), y = cdr(y)) {
02341 if (y == sc->NIL) {
02342 Error_0(sc,"not enough arguments");
02343 } else {
02344 new_slot_in_env(sc, car(x), car(y));
02345 }
02346 }
02347 if (x == sc->NIL) {
02348
02349
02350
02351
02352
02353 } else if (is_symbol(x))
02354 new_slot_in_env(sc, x, y);
02355 else {
02356 Error_1(sc,"syntax error in closure: not a symbol:", x);
02357 }
02358 sc->code = cdr(closure_code(sc->code));
02359 sc->args = sc->NIL;
02360 s_goto(sc,OP_BEGIN);
02361 } else if (is_continuation(sc->code)) {
02362 sc->dump = cont_dump(sc->code);
02363 s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
02364 } else {
02365 Error_0(sc,"illegal function");
02366 }
02367
02368 case OP_DOMACRO:
02369 sc->code = sc->value;
02370 s_goto(sc,OP_EVAL);
02371
02372 case OP_LAMBDA:
02373 s_return(sc,mk_closure(sc, sc->code, sc->envir));
02374
02375 case OP_MKCLOSURE:
02376 x=car(sc->args);
02377 if(car(x)==sc->LAMBDA) {
02378 x=cdr(x);
02379 }
02380 if(cdr(sc->args)==sc->NIL) {
02381 y=sc->envir;
02382 } else {
02383 y=cadr(sc->args);
02384 }
02385 s_return(sc,mk_closure(sc, x, y));
02386
02387 case OP_QUOTE:
02388 x=car(sc->code);
02389 s_return(sc,car(sc->code));
02390
02391 case OP_DEF0:
02392 if (is_pair(car(sc->code))) {
02393 x = caar(sc->code);
02394 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
02395 } else {
02396 x = car(sc->code);
02397 sc->code = cadr(sc->code);
02398 }
02399 if (!is_symbol(x)) {
02400 Error_0(sc,"variable is not a symbol");
02401 }
02402 s_save(sc,OP_DEF1, sc->NIL, x);
02403 s_goto(sc,OP_EVAL);
02404
02405 case OP_DEF1:
02406 x=find_slot_in_env(sc,sc->envir,sc->code,0);
02407 if (x != sc->NIL) {
02408 set_slot_in_env(sc, x, sc->value);
02409 } else {
02410 new_slot_in_env(sc, sc->code, sc->value);
02411 }
02412 s_return(sc,sc->code);
02413
02414
02415 case OP_DEFP:
02416 x=sc->envir;
02417 if(cdr(sc->args)!=sc->NIL) {
02418 x=cadr(sc->args);
02419 }
02420 s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
02421
02422 case OP_SET0:
02423 s_save(sc,OP_SET1, sc->NIL, car(sc->code));
02424 sc->code = cadr(sc->code);
02425 s_goto(sc,OP_EVAL);
02426
02427 case OP_SET1:
02428 y=find_slot_in_env(sc,sc->envir,sc->code,1);
02429 if (y != sc->NIL) {
02430 set_slot_in_env(sc, y, sc->value);
02431 s_return(sc,sc->value);
02432 } else {
02433 Error_1(sc,"set!: unbound variable:", sc->code);
02434 }
02435
02436
02437 case OP_BEGIN:
02438 if (!is_pair(sc->code)) {
02439 s_return(sc,sc->code);
02440 }
02441 if (cdr(sc->code) != sc->NIL) {
02442 s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
02443 }
02444 sc->code = car(sc->code);
02445 s_goto(sc,OP_EVAL);
02446
02447 case OP_IF0:
02448 s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
02449 sc->code = car(sc->code);
02450 s_goto(sc,OP_EVAL);
02451
02452 case OP_IF1:
02453 if (is_true(sc->value))
02454 sc->code = car(sc->code);
02455 else
02456 sc->code = cadr(sc->code);
02457
02458 s_goto(sc,OP_EVAL);
02459
02460 case OP_LET0:
02461 sc->args = sc->NIL;
02462 sc->value = sc->code;
02463 sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
02464 s_goto(sc,OP_LET1);
02465
02466 case OP_LET1:
02467 sc->args = cons(sc, sc->value, sc->args);
02468 if (is_pair(sc->code)) {
02469 s_save(sc,OP_LET1, sc->args, cdr(sc->code));
02470 sc->code = cadar(sc->code);
02471 sc->args = sc->NIL;
02472 s_goto(sc,OP_EVAL);
02473 } else {
02474 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02475 sc->code = car(sc->args);
02476 sc->args = cdr(sc->args);
02477 s_goto(sc,OP_LET2);
02478 }
02479
02480 case OP_LET2:
02481 new_frame_in_env(sc, sc->envir);
02482 for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
02483 y != sc->NIL; x = cdr(x), y = cdr(y)) {
02484 new_slot_in_env(sc, caar(x), car(y));
02485 }
02486 if (is_symbol(car(sc->code))) {
02487 for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
02488
02489 sc->args = cons(sc, caar(x), sc->args);
02490 }
02491 x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
02492 new_slot_in_env(sc, car(sc->code), x);
02493 sc->code = cddr(sc->code);
02494 sc->args = sc->NIL;
02495 } else {
02496 sc->code = cdr(sc->code);
02497 sc->args = sc->NIL;
02498 }
02499 s_goto(sc,OP_BEGIN);
02500
02501 case OP_LET0AST:
02502 if (car(sc->code) == sc->NIL) {
02503 new_frame_in_env(sc, sc->envir);
02504 sc->code = cdr(sc->code);
02505 s_goto(sc,OP_BEGIN);
02506 }
02507 s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
02508 sc->code = cadaar(sc->code);
02509 s_goto(sc,OP_EVAL);
02510
02511 case OP_LET1AST:
02512 new_frame_in_env(sc, sc->envir);
02513 s_goto(sc,OP_LET2AST);
02514
02515 case OP_LET2AST:
02516 new_slot_in_env(sc, caar(sc->code), sc->value);
02517 sc->code = cdr(sc->code);
02518 if (is_pair(sc->code)) {
02519 s_save(sc,OP_LET2AST, sc->args, sc->code);
02520 sc->code = cadar(sc->code);
02521 sc->args = sc->NIL;
02522 s_goto(sc,OP_EVAL);
02523 } else {
02524 sc->code = sc->args;
02525 sc->args = sc->NIL;
02526 s_goto(sc,OP_BEGIN);
02527 }
02528 default:
02529 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
02530 Error_0(sc,sc->strbuff);
02531 }
02532 return sc->T;
02533 }
02534
02535 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
02536 pointer x, y;
02537
02538 switch (op) {
02539 case OP_LET0REC:
02540 new_frame_in_env(sc, sc->envir);
02541 sc->args = sc->NIL;
02542 sc->value = sc->code;
02543 sc->code = car(sc->code);
02544 s_goto(sc,OP_LET1REC);
02545
02546 case OP_LET1REC:
02547 sc->args = cons(sc, sc->value, sc->args);
02548 if (is_pair(sc->code)) {
02549 s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
02550 sc->code = cadar(sc->code);
02551 sc->args = sc->NIL;
02552 s_goto(sc,OP_EVAL);
02553 } else {
02554 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02555 sc->code = car(sc->args);
02556 sc->args = cdr(sc->args);
02557 s_goto(sc,OP_LET2REC);
02558 }
02559
02560 case OP_LET2REC:
02561 for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
02562 new_slot_in_env(sc, caar(x), car(y));
02563 }
02564 sc->code = cdr(sc->code);
02565 sc->args = sc->NIL;
02566 s_goto(sc,OP_BEGIN);
02567
02568 case OP_COND0:
02569 if (!is_pair(sc->code)) {
02570 Error_0(sc,"syntax error in cond");
02571 }
02572 s_save(sc,OP_COND1, sc->NIL, sc->code);
02573 sc->code = caar(sc->code);
02574 s_goto(sc,OP_EVAL);
02575
02576 case OP_COND1:
02577 if (is_true(sc->value)) {
02578 if ((sc->code = cdar(sc->code)) == sc->NIL) {
02579 s_return(sc,sc->value);
02580 }
02581 if(car(sc->code)==sc->FEED_TO) {
02582 if(!is_pair(cdr(sc->code))) {
02583 Error_0(sc,"syntax error in cond");
02584 }
02585 x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
02586 sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
02587 s_goto(sc,OP_EVAL);
02588 }
02589 s_goto(sc,OP_BEGIN);
02590 } else {
02591 if ((sc->code = cdr(sc->code)) == sc->NIL) {
02592 s_return(sc,sc->NIL);
02593 } else {
02594 s_save(sc,OP_COND1, sc->NIL, sc->code);
02595 sc->code = caar(sc->code);
02596 s_goto(sc,OP_EVAL);
02597 }
02598 }
02599
02600 case OP_DELAY:
02601 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
02602 typeflag(x)=T_PROMISE;
02603 s_return(sc,x);
02604
02605 case OP_AND0:
02606 if (sc->code == sc->NIL) {
02607 s_return(sc,sc->T);
02608 }
02609 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
02610 sc->code = car(sc->code);
02611 s_goto(sc,OP_EVAL);
02612
02613 case OP_AND1:
02614 if (is_false(sc->value)) {
02615 s_return(sc,sc->value);
02616 } else if (sc->code == sc->NIL) {
02617 s_return(sc,sc->value);
02618 } else {
02619 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
02620 sc->code = car(sc->code);
02621 s_goto(sc,OP_EVAL);
02622 }
02623
02624 case OP_OR0:
02625 if (sc->code == sc->NIL) {
02626 s_return(sc,sc->F);
02627 }
02628 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
02629 sc->code = car(sc->code);
02630 s_goto(sc,OP_EVAL);
02631
02632 case OP_OR1:
02633 if (is_true(sc->value)) {
02634 s_return(sc,sc->value);
02635 } else if (sc->code == sc->NIL) {
02636 s_return(sc,sc->value);
02637 } else {
02638 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
02639 sc->code = car(sc->code);
02640 s_goto(sc,OP_EVAL);
02641 }
02642
02643 case OP_C0STREAM:
02644 s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
02645 sc->code = car(sc->code);
02646 s_goto(sc,OP_EVAL);
02647
02648 case OP_C1STREAM:
02649 sc->args = sc->value;
02650 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
02651 typeflag(x)=T_PROMISE;
02652 s_return(sc,cons(sc, sc->args, x));
02653
02654 case OP_MACRO0:
02655 if (is_pair(car(sc->code))) {
02656 x = caar(sc->code);
02657 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
02658 } else {
02659 x = car(sc->code);
02660 sc->code = cadr(sc->code);
02661 }
02662 if (!is_symbol(x)) {
02663 Error_0(sc,"variable is not a symbol");
02664 }
02665 s_save(sc,OP_MACRO1, sc->NIL, x);
02666 s_goto(sc,OP_EVAL);
02667
02668 case OP_MACRO1:
02669 typeflag(sc->value) = T_MACRO;
02670 x = find_slot_in_env(sc, sc->envir, sc->code, 0);
02671 if (x != sc->NIL) {
02672 set_slot_in_env(sc, x, sc->value);
02673 } else {
02674 new_slot_in_env(sc, sc->code, sc->value);
02675 }
02676 s_return(sc,sc->code);
02677
02678 case OP_CASE0:
02679 s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
02680 sc->code = car(sc->code);
02681 s_goto(sc,OP_EVAL);
02682
02683 case OP_CASE1:
02684 for (x = sc->code; x != sc->NIL; x = cdr(x)) {
02685 if (!is_pair(y = caar(x))) {
02686 break;
02687 }
02688 for ( ; y != sc->NIL; y = cdr(y)) {
02689 if (eqv(car(y), sc->value)) {
02690 break;
02691 }
02692 }
02693 if (y != sc->NIL) {
02694 break;
02695 }
02696 }
02697 if (x != sc->NIL) {
02698 if (is_pair(caar(x))) {
02699 sc->code = cdar(x);
02700 s_goto(sc,OP_BEGIN);
02701 } else {
02702 s_save(sc,OP_CASE2, sc->NIL, cdar(x));
02703 sc->code = caar(x);
02704 s_goto(sc,OP_EVAL);
02705 }
02706 } else {
02707 s_return(sc,sc->NIL);
02708 }
02709
02710 case OP_CASE2:
02711 if (is_true(sc->value)) {
02712 s_goto(sc,OP_BEGIN);
02713 } else {
02714 s_return(sc,sc->NIL);
02715 }
02716
02717 case OP_PAPPLY:
02718 sc->code = car(sc->args);
02719 sc->args = list_star(sc,cdr(sc->args));
02720
02721 s_goto(sc,OP_APPLY);
02722
02723 case OP_PEVAL:
02724 if(cdr(sc->args)!=sc->NIL) {
02725 sc->envir=cadr(sc->args);
02726 }
02727 sc->code = car(sc->args);
02728 s_goto(sc,OP_EVAL);
02729
02730 case OP_CONTINUATION:
02731 sc->code = car(sc->args);
02732 sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
02733 s_goto(sc,OP_APPLY);
02734
02735 default:
02736 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
02737 Error_0(sc,sc->strbuff);
02738 }
02739 return sc->T;
02740 }
02741
02742 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
02743 pointer x;
02744 num v;
02745 #if USE_MATH
02746 double dd;
02747 #endif
02748
02749 switch (op) {
02750 #if USE_MATH
02751 case OP_INEX2EX:
02752 x=car(sc->args);
02753 if(is_integer(x)) {
02754 s_return(sc,x);
02755 } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
02756 s_return(sc,mk_integer(sc,ivalue(x)));
02757 } else {
02758 Error_1(sc,"inexact->exact: not integral:",x);
02759 }
02760
02761 case OP_EXP:
02762 x=car(sc->args);
02763 s_return(sc, mk_real(sc, exp(rvalue(x))));
02764
02765 case OP_LOG:
02766 x=car(sc->args);
02767 s_return(sc, mk_real(sc, log(rvalue(x))));
02768
02769 case OP_SIN:
02770 x=car(sc->args);
02771 s_return(sc, mk_real(sc, sin(rvalue(x))));
02772
02773 case OP_COS:
02774 x=car(sc->args);
02775 s_return(sc, mk_real(sc, cos(rvalue(x))));
02776
02777 case OP_TAN:
02778 x=car(sc->args);
02779 s_return(sc, mk_real(sc, tan(rvalue(x))));
02780
02781 case OP_ASIN:
02782 x=car(sc->args);
02783 s_return(sc, mk_real(sc, asin(rvalue(x))));
02784
02785 case OP_ACOS:
02786 x=car(sc->args);
02787 s_return(sc, mk_real(sc, acos(rvalue(x))));
02788
02789 case OP_ATAN:
02790 x=car(sc->args);
02791 if(cdr(sc->args)==sc->NIL) {
02792 s_return(sc, mk_real(sc, atan(rvalue(x))));
02793 } else {
02794 pointer y=cadr(sc->args);
02795 s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
02796 }
02797
02798 case OP_SQRT:
02799 x=car(sc->args);
02800 s_return(sc, mk_real(sc, sqrt(rvalue(x))));
02801
02802 case OP_EXPT:
02803 x=car(sc->args);
02804 if(cdr(sc->args)==sc->NIL) {
02805 Error_0(sc,"expt: needs two arguments");
02806 } else {
02807 pointer y=cadr(sc->args);
02808 s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
02809 }
02810
02811 case OP_FLOOR:
02812 x=car(sc->args);
02813 s_return(sc, mk_real(sc, floor(rvalue(x))));
02814
02815 case OP_CEILING:
02816 x=car(sc->args);
02817 s_return(sc, mk_real(sc, ceil(rvalue(x))));
02818
02819 case OP_TRUNCATE : {
02820 double rvalue_of_x ;
02821 x=car(sc->args);
02822 rvalue_of_x = rvalue(x) ;
02823 if (rvalue_of_x > 0) {
02824 s_return(sc, mk_real(sc, floor(rvalue_of_x)));
02825 } else {
02826 s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
02827 }
02828 }
02829
02830 case OP_ROUND:
02831 x=car(sc->args);
02832 s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
02833 #endif
02834
02835 case OP_ADD:
02836 v=num_zero;
02837 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
02838 v=num_add(v,nvalue(car(x)));
02839 }
02840 s_return(sc,mk_number(sc, v));
02841
02842 case OP_MUL:
02843 v=num_one;
02844 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
02845 v=num_mul(v,nvalue(car(x)));
02846 }
02847 s_return(sc,mk_number(sc, v));
02848
02849 case OP_SUB:
02850 if(cdr(sc->args)==sc->NIL) {
02851 x=sc->args;
02852 v=num_zero;
02853 } else {
02854 x = cdr(sc->args);
02855 v = nvalue(car(sc->args));
02856 }
02857 for (; x != sc->NIL; x = cdr(x)) {
02858 v=num_sub(v,nvalue(car(x)));
02859 }
02860 s_return(sc,mk_number(sc, v));
02861
02862 case OP_DIV:
02863 if(cdr(sc->args)==sc->NIL) {
02864 x=sc->args;
02865 v=num_one;
02866 } else {
02867 x = cdr(sc->args);
02868 v = nvalue(car(sc->args));
02869 }
02870 for (; x != sc->NIL; x = cdr(x)) {
02871 if (!is_zero_double(rvalue(car(x))))
02872 v=num_div(v,nvalue(car(x)));
02873 else {
02874 Error_0(sc,"/: division by zero");
02875 }
02876 }
02877 s_return(sc,mk_number(sc, v));
02878
02879 case OP_INTDIV:
02880 if(cdr(sc->args)==sc->NIL) {
02881 x=sc->args;
02882 v=num_one;
02883 } else {
02884 x = cdr(sc->args);
02885 v = nvalue(car(sc->args));
02886 }
02887 for (; x != sc->NIL; x = cdr(x)) {
02888 if (ivalue(car(x)) != 0)
02889 v=num_intdiv(v,nvalue(car(x)));
02890 else {
02891 Error_0(sc,"quotient: division by zero");
02892 }
02893 }
02894 s_return(sc,mk_number(sc, v));
02895
02896 case OP_REM:
02897 v = nvalue(car(sc->args));
02898 if (ivalue(cadr(sc->args)) != 0)
02899 v=num_rem(v,nvalue(cadr(sc->args)));
02900 else {
02901 Error_0(sc,"remainder: division by zero");
02902 }
02903 s_return(sc,mk_number(sc, v));
02904
02905 case OP_MOD:
02906 v = nvalue(car(sc->args));
02907 if (ivalue(cadr(sc->args)) != 0)
02908 v=num_mod(v,nvalue(cadr(sc->args)));
02909 else {
02910 Error_0(sc,"modulo: division by zero");
02911 }
02912 s_return(sc,mk_number(sc, v));
02913
02914 case OP_CAR:
02915 s_return(sc,caar(sc->args));
02916
02917 case OP_CDR:
02918 s_return(sc,cdar(sc->args));
02919
02920 case OP_CONS:
02921 cdr(sc->args) = cadr(sc->args);
02922 s_return(sc,sc->args);
02923
02924 case OP_SETCAR:
02925 if(!is_immutable(car(sc->args))) {
02926 caar(sc->args) = cadr(sc->args);
02927 s_return(sc,car(sc->args));
02928 } else {
02929 Error_0(sc,"set-car!: unable to alter immutable pair");
02930 }
02931
02932 case OP_SETCDR:
02933 if(!is_immutable(car(sc->args))) {
02934 cdar(sc->args) = cadr(sc->args);
02935 s_return(sc,car(sc->args));
02936 } else {
02937 Error_0(sc,"set-cdr!: unable to alter immutable pair");
02938 }
02939
02940 case OP_CHAR2INT: {
02941 char c;
02942 c=(char)ivalue(car(sc->args));
02943 s_return(sc,mk_integer(sc,(unsigned char)c));
02944 }
02945
02946 case OP_INT2CHAR: {
02947 unsigned char c;
02948 c=(unsigned char)ivalue(car(sc->args));
02949 s_return(sc,mk_character(sc,(char)c));
02950 }
02951
02952 case OP_CHARUPCASE: {
02953 unsigned char c;
02954 c=(unsigned char)ivalue(car(sc->args));
02955 c=toupper(c);
02956 s_return(sc,mk_character(sc,(char)c));
02957 }
02958
02959 case OP_CHARDNCASE: {
02960 unsigned char c;
02961 c=(unsigned char)ivalue(car(sc->args));
02962 c=tolower(c);
02963 s_return(sc,mk_character(sc,(char)c));
02964 }
02965
02966 case OP_STR2SYM:
02967 s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
02968
02969 case OP_STR2ATOM: {
02970 char *s=strvalue(car(sc->args));
02971 if(*s=='#') {
02972 s_return(sc, mk_sharp_const(sc, s+1));
02973 } else {
02974 s_return(sc, mk_atom(sc, s));
02975 }
02976 }
02977
02978 case OP_SYM2STR:
02979 x=mk_string(sc,symname(car(sc->args)));
02980 setimmutable(x);
02981 s_return(sc,x);
02982 case OP_ATOM2STR:
02983 x=car(sc->args);
02984 if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
02985 char *p;
02986 int len;
02987 atom2str(sc,x,0,&p,&len);
02988 s_return(sc,mk_counted_string(sc,p,len));
02989 } else {
02990 Error_1(sc, "atom->string: not an atom:", x);
02991 }
02992
02993 case OP_MKSTRING: {
02994 int fill=' ';
02995 int len;
02996
02997 len=ivalue(car(sc->args));
02998
02999 if(cdr(sc->args)!=sc->NIL) {
03000 fill=charvalue(cadr(sc->args));
03001 }
03002 s_return(sc,mk_empty_string(sc,len,(char)fill));
03003 }
03004
03005 case OP_STRLEN:
03006 s_return(sc,mk_integer(sc,strlength(car(sc->args))));
03007
03008 case OP_STRREF: {
03009 char *str;
03010 int index;
03011
03012 str=strvalue(car(sc->args));
03013
03014 index=ivalue(cadr(sc->args));
03015
03016 if(index>=strlength(car(sc->args))) {
03017 Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
03018 }
03019
03020 s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
03021 }
03022
03023 case OP_STRSET: {
03024 char *str;
03025 int index;
03026 int c;
03027
03028 if(is_immutable(car(sc->args))) {
03029 Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
03030 }
03031 str=strvalue(car(sc->args));
03032
03033 index=ivalue(cadr(sc->args));
03034 if(index>=strlength(car(sc->args))) {
03035 Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
03036 }
03037
03038 c=charvalue(caddr(sc->args));
03039
03040 str[index]=(char)c;
03041 s_return(sc,car(sc->args));
03042 }
03043
03044 case OP_STRAPPEND: {
03045
03046 int len = 0;
03047 pointer newstr;
03048 char *pos;
03049
03050
03051 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
03052 len += strlength(car(x));
03053 }
03054 newstr = mk_empty_string(sc, len, ' ');
03055
03056 for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
03057 pos += strlength(car(x)), x = cdr(x)) {
03058 memcpy(pos, strvalue(car(x)), strlength(car(x)));
03059 }
03060 s_return(sc, newstr);
03061 }
03062
03063 case OP_SUBSTR: {
03064 char *str;
03065 int index0;
03066 int index1;
03067 int len;
03068
03069 str=strvalue(car(sc->args));
03070
03071 index0=ivalue(cadr(sc->args));
03072
03073 if(index0>strlength(car(sc->args))) {
03074 Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
03075 }
03076
03077 if(cddr(sc->args)!=sc->NIL) {
03078 index1=ivalue(caddr(sc->args));
03079 if(index1>strlength(car(sc->args)) || index1<index0) {
03080 Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
03081 }
03082 } else {
03083 index1=strlength(car(sc->args));
03084 }
03085
03086 len=index1-index0;
03087 x=mk_empty_string(sc,len,' ');
03088 memcpy(strvalue(x),str+index0,len);
03089 strvalue(x)[len]=0;
03090
03091 s_return(sc,x);
03092 }
03093
03094 case OP_VECTOR: {
03095 int i;
03096 pointer vec;
03097 int len=list_length(sc,sc->args);
03098 if(len<0) {
03099 Error_1(sc,"vector: not a proper list:",sc->args);
03100 }
03101 vec=mk_vector(sc,len);
03102 for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
03103 set_vector_elem(vec,i,car(x));
03104 }
03105 s_return(sc,vec);
03106 }
03107
03108 case OP_MKVECTOR: {
03109 pointer fill=sc->NIL;
03110 int len;
03111 pointer vec;
03112
03113 len=ivalue(car(sc->args));
03114
03115 if(cdr(sc->args)!=sc->NIL) {
03116 fill=cadr(sc->args);
03117 }
03118 vec=mk_vector(sc,len);
03119 if(fill!=sc->NIL) {
03120 fill_vector(vec,fill);
03121 }
03122 s_return(sc,vec);
03123 }
03124
03125 case OP_VECLEN:
03126 s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
03127
03128 case OP_VECREF: {
03129 int index;
03130
03131 index=ivalue(cadr(sc->args));
03132
03133 if(index>=ivalue(car(sc->args))) {
03134 Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
03135 }
03136
03137 s_return(sc,vector_elem(car(sc->args),index));
03138 }
03139
03140 case OP_VECSET: {
03141 int index;
03142
03143 if(is_immutable(car(sc->args))) {
03144 Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
03145 }
03146
03147 index=ivalue(cadr(sc->args));
03148 if(index>=ivalue(car(sc->args))) {
03149 Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
03150 }
03151
03152 set_vector_elem(car(sc->args),index,caddr(sc->args));
03153 s_return(sc,car(sc->args));
03154 }
03155
03156 default:
03157 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
03158 Error_0(sc,sc->strbuff);
03159 }
03160 return sc->T;
03161 }
03162
03163 static int list_length(scheme *sc, pointer a) {
03164 int v=0;
03165 pointer x;
03166 for (x = a, v = 0; is_pair(x); x = cdr(x)) {
03167 ++v;
03168 }
03169 if(x==sc->NIL) {
03170 return v;
03171 }
03172 return -1;
03173 }
03174
03175 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
03176 pointer x;
03177 num v;
03178 int (*comp_func)(num,num)=0;
03179
03180 switch (op) {
03181 case OP_NOT:
03182 s_retbool(is_false(car(sc->args)));
03183 case OP_BOOLP:
03184 s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
03185 case OP_EOFOBJP:
03186 s_retbool(car(sc->args) == sc->EOF_OBJ);
03187 case OP_NULLP:
03188 s_retbool(car(sc->args) == sc->NIL);
03189 case OP_NUMEQ:
03190 case OP_LESS:
03191 case OP_GRE:
03192 case OP_LEQ:
03193 case OP_GEQ:
03194 switch(op) {
03195 case OP_NUMEQ: comp_func=num_eq; break;
03196 case OP_LESS: comp_func=num_lt; break;
03197 case OP_GRE: comp_func=num_gt; break;
03198 case OP_LEQ: comp_func=num_le; break;
03199 case OP_GEQ: comp_func=num_ge; break;
03200 default:
03201 ;
03202 }
03203 x=sc->args;
03204 v=nvalue(car(x));
03205 x=cdr(x);
03206
03207 for (; x != sc->NIL; x = cdr(x)) {
03208 if(!comp_func(v,nvalue(car(x)))) {
03209 s_retbool(0);
03210 }
03211 v=nvalue(car(x));
03212 }
03213 s_retbool(1);
03214 case OP_SYMBOLP:
03215 s_retbool(is_symbol(car(sc->args)));
03216 case OP_NUMBERP:
03217 s_retbool(is_number(car(sc->args)));
03218 case OP_STRINGP:
03219 s_retbool(is_string(car(sc->args)));
03220 case OP_INTEGERP:
03221 s_retbool(is_integer(car(sc->args)));
03222 case OP_REALP:
03223 s_retbool(is_number(car(sc->args)));
03224 case OP_CHARP:
03225 s_retbool(is_character(car(sc->args)));
03226 #if USE_CHAR_CLASSIFIERS
03227 case OP_CHARAP:
03228 s_retbool(Cisalpha(ivalue(car(sc->args))));
03229 case OP_CHARNP:
03230 s_retbool(Cisdigit(ivalue(car(sc->args))));
03231 case OP_CHARWP:
03232 s_retbool(Cisspace(ivalue(car(sc->args))));
03233 case OP_CHARUP:
03234 s_retbool(Cisupper(ivalue(car(sc->args))));
03235 case OP_CHARLP:
03236 s_retbool(Cislower(ivalue(car(sc->args))));
03237 #endif
03238 case OP_PORTP:
03239 s_retbool(is_port(car(sc->args)));
03240 case OP_INPORTP:
03241 s_retbool(is_inport(car(sc->args)));
03242 case OP_OUTPORTP:
03243 s_retbool(is_outport(car(sc->args)));
03244 case OP_PROCP:
03245
03246
03247
03248
03249
03250 s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
03251 || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
03252 case OP_PAIRP:
03253 s_retbool(is_pair(car(sc->args)));
03254 case OP_LISTP: {
03255 pointer slow, fast;
03256 slow = fast = car(sc->args);
03257 while (1) {
03258 if (!is_pair(fast)) s_retbool(fast == sc->NIL);
03259 fast = cdr(fast);
03260 if (!is_pair(fast)) s_retbool(fast == sc->NIL);
03261 fast = cdr(fast);
03262 slow = cdr(slow);
03263 if (fast == slow) {
03264
03265
03266
03267 s_retbool(0);
03268 }
03269 }
03270 }
03271 case OP_ENVP:
03272 s_retbool(is_environment(car(sc->args)));
03273 case OP_VECTORP:
03274 s_retbool(is_vector(car(sc->args)));
03275 case OP_EQ:
03276 s_retbool(car(sc->args) == cadr(sc->args));
03277 case OP_EQV:
03278 s_retbool(eqv(car(sc->args), cadr(sc->args)));
03279 default:
03280 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
03281 Error_0(sc,sc->strbuff);
03282 }
03283 return sc->T;
03284 }
03285
03286 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
03287 pointer x, y;
03288
03289 switch (op) {
03290 case OP_FORCE:
03291 sc->code = car(sc->args);
03292 if (is_promise(sc->code)) {
03293
03294 s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
03295 sc->args = sc->NIL;
03296 s_goto(sc,OP_APPLY);
03297 } else {
03298 s_return(sc,sc->code);
03299 }
03300
03301 case OP_SAVE_FORCED:
03302 memcpy(sc->code,sc->value,sizeof(struct cell));
03303 s_return(sc,sc->value);
03304
03305 case OP_WRITE:
03306 case OP_DISPLAY:
03307 case OP_WRITE_CHAR:
03308 if(is_pair(cdr(sc->args))) {
03309 if(cadr(sc->args)!=sc->outport) {
03310 x=cons(sc,sc->outport,sc->NIL);
03311 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
03312 sc->outport=cadr(sc->args);
03313 }
03314 }
03315 sc->args = car(sc->args);
03316 if(op==OP_WRITE) {
03317 sc->print_flag = 1;
03318 } else {
03319 sc->print_flag = 0;
03320 }
03321 s_goto(sc,OP_P0LIST);
03322
03323 case OP_NEWLINE:
03324 if(is_pair(sc->args)) {
03325 if(car(sc->args)!=sc->outport) {
03326 x=cons(sc,sc->outport,sc->NIL);
03327 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
03328 sc->outport=car(sc->args);
03329 }
03330 }
03331 putstr(sc, "\n");
03332 s_return(sc,sc->T);
03333
03334 case OP_ERR0:
03335 sc->retcode=-1;
03336 if (!is_string(car(sc->args))) {
03337 sc->args=cons(sc,mk_string(sc," -- "),sc->args);
03338 setimmutable(car(sc->args));
03339 }
03340 putstr(sc, "Error: ");
03341 putstr(sc, strvalue(car(sc->args)));
03342 sc->args = cdr(sc->args);
03343 s_goto(sc,OP_ERR1);
03344
03345 case OP_ERR1:
03346 putstr(sc, " ");
03347 if (sc->args != sc->NIL) {
03348 s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
03349 sc->args = car(sc->args);
03350 sc->print_flag = 1;
03351 s_goto(sc,OP_P0LIST);
03352 } else {
03353 putstr(sc, "\n");
03354 if(sc->interactive_repl) {
03355 s_goto(sc,OP_T0LVL);
03356 } else {
03357 return sc->NIL;
03358 }
03359 }
03360
03361 case OP_REVERSE:
03362 s_return(sc,reverse(sc, car(sc->args)));
03363
03364 case OP_LIST_STAR:
03365 s_return(sc,list_star(sc,sc->args));
03366
03367 case OP_APPEND:
03368 if(sc->args==sc->NIL) {
03369 s_return(sc,sc->NIL);
03370 }
03371 x=car(sc->args);
03372 if(cdr(sc->args)==sc->NIL) {
03373 s_return(sc,sc->args);
03374 }
03375 for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
03376 x=append(sc,x,car(y));
03377 }
03378 s_return(sc,x);
03379
03380 #if USE_PLIST
03381 case OP_PUT:
03382 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
03383 Error_0(sc,"illegal use of put");
03384 }
03385 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
03386 if (caar(x) == y) {
03387 break;
03388 }
03389 }
03390 if (x != sc->NIL)
03391 cdar(x) = caddr(sc->args);
03392 else
03393 symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
03394 symprop(car(sc->args)));
03395 s_return(sc,sc->T);
03396
03397 case OP_GET:
03398 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
03399 Error_0(sc,"illegal use of get");
03400 }
03401 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
03402 if (caar(x) == y) {
03403 break;
03404 }
03405 }
03406 if (x != sc->NIL) {
03407 s_return(sc,cdar(x));
03408 } else {
03409 s_return(sc,sc->NIL);
03410 }
03411 #endif
03412 case OP_QUIT:
03413 if(is_pair(sc->args)) {
03414 sc->retcode=ivalue(car(sc->args));
03415 }
03416 return (sc->NIL);
03417
03418 case OP_GC:
03419 gc(sc, sc->NIL, sc->NIL);
03420 s_return(sc,sc->T);
03421
03422 case OP_GCVERB:
03423 { int was = sc->gc_verbose;
03424
03425 sc->gc_verbose = (car(sc->args) != sc->F);
03426 s_retbool(was);
03427 }
03428
03429 case OP_NEWSEGMENT:
03430 if (!is_pair(sc->args) || !is_number(car(sc->args))) {
03431 Error_0(sc,"new-segment: argument must be a number");
03432 }
03433 alloc_cellseg(sc, (int) ivalue(car(sc->args)));
03434 s_return(sc,sc->T);
03435
03436 case OP_OBLIST:
03437 s_return(sc, oblist_all_symbols(sc));
03438
03439 case OP_CURR_INPORT:
03440 s_return(sc,sc->inport);
03441
03442 case OP_CURR_OUTPORT:
03443 s_return(sc,sc->outport);
03444
03445 case OP_OPEN_INFILE:
03446 case OP_OPEN_OUTFILE:
03447 case OP_OPEN_INOUTFILE: {
03448 int prop=0;
03449 pointer p;
03450 switch(op) {
03451 case OP_OPEN_INFILE: prop=port_input; break;
03452 case OP_OPEN_OUTFILE: prop=port_output; break;
03453 case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
03454 default:
03455 ;
03456 }
03457 p=port_from_filename(sc,strvalue(car(sc->args)),prop);
03458 if(p==sc->NIL) {
03459 s_return(sc,sc->F);
03460 }
03461 s_return(sc,p);
03462 }
03463
03464 #if USE_STRING_PORTS
03465 case OP_OPEN_INSTRING:
03466 case OP_OPEN_OUTSTRING:
03467 case OP_OPEN_INOUTSTRING: {
03468 int prop=0;
03469 pointer p;
03470 switch(op) {
03471 case OP_OPEN_INSTRING: prop=port_input; break;
03472 case OP_OPEN_OUTSTRING: prop=port_output; break;
03473 case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
03474 default:
03475 ;
03476 }
03477 p=port_from_string(sc, strvalue(car(sc->args)),
03478 strvalue(car(sc->args))+strlength(car(sc->args)), prop);
03479 if(p==sc->NIL) {
03480 s_return(sc,sc->F);
03481 }
03482 s_return(sc,p);
03483 }
03484 #endif
03485
03486 case OP_CLOSE_INPORT:
03487 port_close(sc,car(sc->args),port_input);
03488 s_return(sc,sc->T);
03489
03490 case OP_CLOSE_OUTPORT:
03491 port_close(sc,car(sc->args),port_output);
03492 s_return(sc,sc->T);
03493
03494 case OP_INT_ENV:
03495 s_return(sc,sc->global_env);
03496
03497 case OP_CURR_ENV:
03498 s_return(sc,sc->envir);
03499 default:
03500 ;
03501 }
03502 return sc->T;
03503 }
03504
03505 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
03506 pointer x;
03507
03508 if(sc->nesting!=0) {
03509 int n=sc->nesting;
03510 sc->nesting=0;
03511 sc->retcode=-1;
03512 Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
03513 }
03514
03515 switch (op) {
03516
03517 case OP_READ:
03518 if(!is_pair(sc->args)) {
03519 s_goto(sc,OP_READ_INTERNAL);
03520 }
03521 if(!is_inport(car(sc->args))) {
03522 Error_1(sc,"read: not an input port:",car(sc->args));
03523 }
03524 if(car(sc->args)==sc->inport) {
03525 s_goto(sc,OP_READ_INTERNAL);
03526 }
03527 x=sc->inport;
03528 sc->inport=car(sc->args);
03529 x=cons(sc,x,sc->NIL);
03530 s_save(sc,OP_SET_INPORT, x, sc->NIL);
03531 s_goto(sc,OP_READ_INTERNAL);
03532
03533 case OP_READ_CHAR:
03534 case OP_PEEK_CHAR: {
03535 int c;
03536 if(is_pair(sc->args)) {
03537 if(car(sc->args)!=sc->inport) {
03538 x=sc->inport;
03539 x=cons(sc,x,sc->NIL);
03540 s_save(sc,OP_SET_INPORT, x, sc->NIL);
03541 sc->inport=car(sc->args);
03542 }
03543 }
03544 c=inchar(sc);
03545 if(c==EOF) {
03546 s_return(sc,sc->EOF_OBJ);
03547 }
03548 if(sc->op==OP_PEEK_CHAR) {
03549 backchar(sc,c);
03550 }
03551 s_return(sc,mk_character(sc,c));
03552 }
03553
03554 case OP_CHAR_READY: {
03555 pointer p=sc->inport;
03556 int res;
03557 if(is_pair(sc->args)) {
03558 p=car(sc->args);
03559 }
03560 res=p->_object._port->kind&port_string;
03561 s_retbool(res);
03562 }
03563
03564 case OP_SET_INPORT:
03565 sc->inport=car(sc->args);
03566 s_return(sc,sc->value);
03567
03568 case OP_SET_OUTPORT:
03569 sc->outport=car(sc->args);
03570 s_return(sc,sc->value);
03571
03572 case OP_RDSEXPR:
03573 switch (sc->tok) {
03574 case TOK_EOF:
03575 if(sc->inport==sc->loadport) {
03576 sc->args=sc->NIL;
03577 s_goto(sc,OP_QUIT);
03578 } else {
03579 s_return(sc,sc->EOF_OBJ);
03580 }
03581 case TOK_COMMENT: {
03582 int c;
03583 while ((c=inchar(sc)) != '\n' && c!=EOF)
03584 ;
03585 sc->tok = token(sc);
03586 s_goto(sc,OP_RDSEXPR);
03587 }
03588 case TOK_VEC:
03589 s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
03590
03591 case TOK_LPAREN:
03592 sc->tok = token(sc);
03593 if (sc->tok == TOK_RPAREN) {
03594 s_return(sc,sc->NIL);
03595 } else if (sc->tok == TOK_DOT) {
03596 Error_0(sc,"syntax error: illegal dot expression");
03597 } else {
03598 sc->nesting_stack[sc->file_i]++;
03599 s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
03600 s_goto(sc,OP_RDSEXPR);
03601 }
03602 case TOK_QUOTE:
03603 s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
03604 sc->tok = token(sc);
03605 s_goto(sc,OP_RDSEXPR);
03606 case TOK_BQUOTE:
03607 sc->tok = token(sc);
03608 if(sc->tok==TOK_VEC) {
03609 s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
03610 sc->tok=TOK_LPAREN;
03611 s_goto(sc,OP_RDSEXPR);
03612 } else {
03613 s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
03614 }
03615 s_goto(sc,OP_RDSEXPR);
03616 case TOK_COMMA:
03617 s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
03618 sc->tok = token(sc);
03619 s_goto(sc,OP_RDSEXPR);
03620 case TOK_ATMARK:
03621 s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
03622 sc->tok = token(sc);
03623 s_goto(sc,OP_RDSEXPR);
03624 case TOK_ATOM:
03625 s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
03626 case TOK_DQUOTE:
03627 x=readstrexp(sc);
03628 if(x==sc->F) {
03629 Error_0(sc,"Error reading string");
03630 }
03631 setimmutable(x);
03632 s_return(sc,x);
03633 case TOK_SHARP: {
03634 pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
03635 if(f==sc->NIL) {
03636 Error_0(sc,"undefined sharp expression");
03637 } else {
03638 sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
03639 s_goto(sc,OP_EVAL);
03640 }
03641 }
03642 case TOK_SHARP_CONST:
03643 if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) {
03644 Error_0(sc,"undefined sharp expression");
03645 } else {
03646 s_return(sc,x);
03647 }
03648 default:
03649 Error_0(sc,"syntax error: illegal token");
03650 }
03651 break;
03652
03653 case OP_RDLIST: {
03654 sc->args = cons(sc, sc->value, sc->args);
03655 sc->tok = token(sc);
03656 if (sc->tok == TOK_COMMENT) {
03657 int c;
03658 while ((c=inchar(sc)) != '\n' && c!=EOF)
03659 ;
03660 sc->tok = token(sc);
03661 }
03662 if (sc->tok == TOK_RPAREN) {
03663 int c = inchar(sc);
03664 if (c != '\n') backchar(sc,c);
03665 sc->nesting_stack[sc->file_i]--;
03666 s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
03667 } else if (sc->tok == TOK_DOT) {
03668 s_save(sc,OP_RDDOT, sc->args, sc->NIL);
03669 sc->tok = token(sc);
03670 s_goto(sc,OP_RDSEXPR);
03671 } else {
03672 s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
03673 s_goto(sc,OP_RDSEXPR);
03674 }
03675 }
03676
03677 case OP_RDDOT:
03678 if (token(sc) != TOK_RPAREN) {
03679 Error_0(sc,"syntax error: illegal dot expression");
03680 } else {
03681 sc->nesting_stack[sc->file_i]--;
03682 s_return(sc,reverse_in_place(sc, sc->value, sc->args));
03683 }
03684
03685 case OP_RDQUOTE:
03686 s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
03687
03688 case OP_RDQQUOTE:
03689 s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
03690
03691 case OP_RDQQUOTEVEC:
03692 s_return(sc,cons(sc, mk_symbol(sc,"apply"),
03693 cons(sc, mk_symbol(sc,"vector"),
03694 cons(sc,cons(sc, sc->QQUOTE,
03695 cons(sc,sc->value,sc->NIL)),
03696 sc->NIL))));
03697
03698 case OP_RDUNQUOTE:
03699 s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
03700
03701 case OP_RDUQTSP:
03702 s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
03703
03704 case OP_RDVEC:
03705
03706
03707
03708
03709
03710
03711
03712 sc->args=sc->value;
03713 s_goto(sc,OP_VECTOR);
03714
03715
03716 case OP_P0LIST:
03717 if(is_vector(sc->args)) {
03718 putstr(sc,"#(");
03719 sc->args=cons(sc,sc->args,mk_integer(sc,0));
03720 s_goto(sc,OP_PVECFROM);
03721 } else if(is_environment(sc->args)) {
03722 putstr(sc,"#<ENVIRONMENT>");
03723 s_return(sc,sc->T);
03724 } else if (!is_pair(sc->args)) {
03725 printatom(sc, sc->args, sc->print_flag);
03726 s_return(sc,sc->T);
03727 } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
03728 putstr(sc, "'");
03729 sc->args = cadr(sc->args);
03730 s_goto(sc,OP_P0LIST);
03731 } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
03732 putstr(sc, "`");
03733 sc->args = cadr(sc->args);
03734 s_goto(sc,OP_P0LIST);
03735 } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
03736 putstr(sc, ",");
03737 sc->args = cadr(sc->args);
03738 s_goto(sc,OP_P0LIST);
03739 } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
03740 putstr(sc, ",@");
03741 sc->args = cadr(sc->args);
03742 s_goto(sc,OP_P0LIST);
03743 } else {
03744 putstr(sc, "(");
03745 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
03746 sc->args = car(sc->args);
03747 s_goto(sc,OP_P0LIST);
03748 }
03749
03750 case OP_P1LIST:
03751 if (is_pair(sc->args)) {
03752 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
03753 putstr(sc, " ");
03754 sc->args = car(sc->args);
03755 s_goto(sc,OP_P0LIST);
03756 } else if(is_vector(sc->args)) {
03757 s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
03758 putstr(sc, " . ");
03759 s_goto(sc,OP_P0LIST);
03760 } else {
03761 if (sc->args != sc->NIL) {
03762 putstr(sc, " . ");
03763 printatom(sc, sc->args, sc->print_flag);
03764 }
03765 putstr(sc, ")");
03766 s_return(sc,sc->T);
03767 }
03768 case OP_PVECFROM: {
03769 int i=ivalue_unchecked(cdr(sc->args));
03770 pointer vec=car(sc->args);
03771 int len=ivalue_unchecked(vec);
03772 if(i==len) {
03773 putstr(sc,")");
03774 s_return(sc,sc->T);
03775 } else {
03776 pointer elem=vector_elem(vec,i);
03777 ivalue_unchecked(cdr(sc->args))=i+1;
03778 s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
03779 sc->args=elem;
03780 putstr(sc," ");
03781 s_goto(sc,OP_P0LIST);
03782 }
03783 }
03784
03785 default:
03786 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
03787 Error_0(sc,sc->strbuff);
03788
03789 }
03790 return sc->T;
03791 }
03792
03793 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
03794 pointer x, y;
03795 long v;
03796
03797 switch (op) {
03798 case OP_LIST_LENGTH:
03799 v=list_length(sc,car(sc->args));
03800 if(v<0) {
03801 Error_1(sc,"length: not a list:",car(sc->args));
03802 }
03803 s_return(sc,mk_integer(sc, v));
03804
03805 case OP_ASSQ:
03806 x = car(sc->args);
03807 for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
03808 if (!is_pair(car(y))) {
03809 Error_0(sc,"unable to handle non pair element");
03810 }
03811 if (x == caar(y))
03812 break;
03813 }
03814 if (is_pair(y)) {
03815 s_return(sc,car(y));
03816 } else {
03817 s_return(sc,sc->F);
03818 }
03819
03820
03821 case OP_GET_CLOSURE:
03822 sc->args = car(sc->args);
03823 if (sc->args == sc->NIL) {
03824 s_return(sc,sc->F);
03825 } else if (is_closure(sc->args)) {
03826 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
03827 } else if (is_macro(sc->args)) {
03828 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
03829 } else {
03830 s_return(sc,sc->F);
03831 }
03832 case OP_CLOSUREP:
03833
03834
03835
03836
03837 s_retbool(is_closure(car(sc->args)));
03838 case OP_MACROP:
03839 s_retbool(is_macro(car(sc->args)));
03840 default:
03841 sprintf(sc->strbuff, "%d: illegal operator", sc->op);
03842 Error_0(sc,sc->strbuff);
03843 }
03844 return sc->T;
03845 }
03846
03847 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
03848
03849 typedef int (*test_predicate)(pointer);
03850 static int is_any(pointer p) { return 1;}
03851 static int is_num_integer(pointer p) {
03852 return is_number(p) && ((p)->_object._number.is_fixnum);
03853 }
03854 static int is_nonneg(pointer p) {
03855 return is_num_integer(p) && ivalue(p)>=0;
03856 }
03857
03858
03859 static struct {
03860 test_predicate fct;
03861 const char *kind;
03862 } tests[]={
03863 {0,0},
03864 {is_any, 0},
03865 {is_string, "string"},
03866 {is_symbol, "symbol"},
03867 {is_port, "port"},
03868 {0,"input port"},
03869 {0,"output_port"},
03870 {is_environment, "environment"},
03871 {is_pair, "pair"},
03872 {0, "pair or '()"},
03873 {is_character, "character"},
03874 {is_vector, "vector"},
03875 {is_number, "number"},
03876 {is_num_integer, "integer"},
03877 {is_nonneg, "non-negative integer"}
03878 };
03879
03880 #define TST_NONE 0
03881 #define TST_ANY "\001"
03882 #define TST_STRING "\002"
03883 #define TST_SYMBOL "\003"
03884 #define TST_PORT "\004"
03885 #define TST_INPORT "\005"
03886 #define TST_OUTPORT "\006"
03887 #define TST_ENVIRONMENT "\007"
03888 #define TST_PAIR "\010"
03889 #define TST_LIST "\011"
03890 #define TST_CHAR "\012"
03891 #define TST_VECTOR "\013"
03892 #define TST_NUMBER "\014"
03893 #define TST_INTEGER "\015"
03894 #define TST_NATURAL "\016"
03895
03896 typedef struct {
03897 dispatch_func func;
03898 char *name;
03899 int min_arity;
03900 int max_arity;
03901 char *arg_tests_encoding;
03902 } op_code_info;
03903
03904 #define INF_ARG 0xffff
03905
03906 static op_code_info dispatch_table[]= {
03907 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
03908 #include "opdefines.h"
03909 { 0 }
03910 };
03911
03912 static const char *procname(pointer x) {
03913 int n=procnum(x);
03914 const char *name=dispatch_table[n].name;
03915 if(name==0) {
03916 name="ILLEGAL!";
03917 }
03918 return name;
03919 }
03920
03921
03922 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
03923 int count=0;
03924 int old_op;
03925
03926 sc->op = op;
03927 for (;;) {
03928 op_code_info *pcd=dispatch_table+sc->op;
03929 if (pcd->name!=0) {
03930 char msg[512];
03931 int ok=1;
03932 int n=list_length(sc,sc->args);
03933
03934
03935 if(n<pcd->min_arity) {
03936 ok=0;
03937 sprintf(msg,"%s: needs%s %d argument(s)",
03938 pcd->name,
03939 pcd->min_arity==pcd->max_arity?"":" at least",
03940 pcd->min_arity);
03941 }
03942 if(ok && n>pcd->max_arity) {
03943 ok=0;
03944 sprintf(msg,"%s: needs%s %d argument(s)",
03945 pcd->name,
03946 pcd->min_arity==pcd->max_arity?"":" at most",
03947 pcd->max_arity);
03948 }
03949 if(ok) {
03950 if(pcd->arg_tests_encoding!=0) {
03951 int i=0;
03952 int j;
03953 const char *t=pcd->arg_tests_encoding;
03954 pointer arglist=sc->args;
03955 do {
03956 pointer arg=car(arglist);
03957 j=(int)t[0];
03958 if(j==TST_INPORT[0]) {
03959 if(!is_inport(arg)) break;
03960 } else if(j==TST_OUTPORT[0]) {
03961 if(!is_outport(arg)) break;
03962 } else if(j==TST_LIST[0]) {
03963 if(arg!=sc->NIL && !is_pair(arg)) break;
03964 } else {
03965 if(!tests[j].fct(arg)) break;
03966 }
03967
03968 if(t[1]!=0) {
03969 t++;
03970 }
03971 arglist=cdr(arglist);
03972 i++;
03973 } while(i<n);
03974 if(i<n) {
03975 ok=0;
03976 sprintf(msg,"%s: argument %d must be: %s",
03977 pcd->name,
03978 i+1,
03979 tests[j].kind);
03980 }
03981 }
03982 }
03983 if(!ok) {
03984 if(_Error_1(sc,msg,0)==sc->NIL) {
03985 return;
03986 }
03987 pcd=dispatch_table+sc->op;
03988 }
03989 }
03990 old_op=sc->op;
03991 if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
03992 return;
03993 }
03994 if(sc->no_memory) {
03995 fprintf(stderr,"No memory!\n");
03996 return;
03997 }
03998 count++;
03999 }
04000 }
04001
04002
04003
04004 static void assign_syntax(scheme *sc, char *name) {
04005 pointer x;
04006
04007 x = oblist_add_by_name(sc, name);
04008 typeflag(x) |= T_SYNTAX;
04009 }
04010
04011 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
04012 pointer x, y;
04013
04014 x = mk_symbol(sc, name);
04015 y = mk_proc(sc,op);
04016 new_slot_in_env(sc, x, y);
04017 }
04018
04019 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
04020 pointer y;
04021
04022 y = get_cell(sc, sc->NIL, sc->NIL);
04023 typeflag(y) = (T_PROC | T_ATOM);
04024 ivalue_unchecked(y) = (long) op;
04025 set_integer(y);
04026 return y;
04027 }
04028
04029
04030 static int syntaxnum(pointer p) {
04031 const char *s=strvalue(car(p));
04032 switch(strlength(car(p))) {
04033 case 2:
04034 if(s[0]=='i') return OP_IF0;
04035 else return OP_OR0;
04036 case 3:
04037 if(s[0]=='a') return OP_AND0;
04038 else return OP_LET0;
04039 case 4:
04040 switch(s[3]) {
04041 case 'e': return OP_CASE0;
04042 case 'd': return OP_COND0;
04043 case '*': return OP_LET0AST;
04044 default: return OP_SET0;
04045 }
04046 case 5:
04047 switch(s[2]) {
04048 case 'g': return OP_BEGIN;
04049 case 'l': return OP_DELAY;
04050 case 'c': return OP_MACRO0;
04051 default: return OP_QUOTE;
04052 }
04053 case 6:
04054 switch(s[2]) {
04055 case 'm': return OP_LAMBDA;
04056 case 'f': return OP_DEF0;
04057 default: return OP_LET0REC;
04058 }
04059 default:
04060 return OP_C0STREAM;
04061 }
04062 }
04063
04064
04065 #if USE_INTERFACE
04066 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
04067 return cons(sc,a,b);
04068 }
04069 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
04070 return immutable_cons(sc,a,b);
04071 }
04072
04073 static struct scheme_interface vtbl ={
04074 scheme_define,
04075 s_cons,
04076 s_immutable_cons,
04077 mk_integer,
04078 mk_real,
04079 mk_symbol,
04080 gensym,
04081 mk_string,
04082 mk_counted_string,
04083 mk_character,
04084 mk_vector,
04085 mk_foreign_func,
04086 putstr,
04087 putcharacter,
04088
04089 is_string,
04090 string_value,
04091 is_number,
04092 nvalue,
04093 ivalue,
04094 rvalue,
04095 is_integer,
04096 is_real,
04097 is_character,
04098 charvalue,
04099 is_vector,
04100 ivalue,
04101 fill_vector,
04102 vector_elem,
04103 set_vector_elem,
04104 is_port,
04105 is_pair,
04106 pair_car,
04107 pair_cdr,
04108 set_car,
04109 set_cdr,
04110
04111 is_symbol,
04112 symname,
04113
04114 is_syntax,
04115 is_proc,
04116 is_foreign,
04117 syntaxname,
04118 is_closure,
04119 is_macro,
04120 closure_code,
04121 closure_env,
04122
04123 is_continuation,
04124 is_promise,
04125 is_environment,
04126 is_immutable,
04127 setimmutable,
04128
04129 scheme_load_file,
04130 scheme_load_string
04131 };
04132 #endif
04133
04134 scheme *scheme_init_new() {
04135 scheme *sc=(scheme*)malloc(sizeof(scheme));
04136 if(!scheme_init(sc)) {
04137 free(sc);
04138 return 0;
04139 } else {
04140 return sc;
04141 }
04142 }
04143
04144 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
04145 scheme *sc=(scheme*)malloc(sizeof(scheme));
04146 if(!scheme_init_custom_alloc(sc,malloc,free)) {
04147 free(sc);
04148 return 0;
04149 } else {
04150 return sc;
04151 }
04152 }
04153
04154
04155 int scheme_init(scheme *sc) {
04156 return scheme_init_custom_alloc(sc,malloc,free);
04157 }
04158
04159 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
04160 int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
04161 pointer x;
04162
04163 num_zero.is_fixnum=1;
04164 num_zero.value.ivalue=0;
04165 num_one.is_fixnum=1;
04166 num_one.value.ivalue=1;
04167
04168 #if USE_INTERFACE
04169 sc->vptr=&vtbl;
04170 #endif
04171 sc->gensym_cnt=0;
04172 sc->malloc=malloc;
04173 sc->free=free;
04174 sc->last_cell_seg = -1;
04175 sc->sink = &sc->_sink;
04176 sc->NIL = &sc->_NIL;
04177 sc->T = &sc->_HASHT;
04178 sc->F = &sc->_HASHF;
04179 sc->EOF_OBJ=&sc->_EOF_OBJ;
04180 sc->free_cell = &sc->_NIL;
04181 sc->fcells = 0;
04182 sc->no_memory=0;
04183 sc->inport=sc->NIL;
04184 sc->outport=sc->NIL;
04185 sc->save_inport=sc->NIL;
04186 sc->loadport=sc->NIL;
04187 sc->nesting=0;
04188 sc->interactive_repl=0;
04189
04190 if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
04191 sc->no_memory=1;
04192 return 0;
04193 }
04194 sc->gc_verbose = 0;
04195 dump_stack_initialize(sc);
04196 sc->code = sc->NIL;
04197 sc->tracing=0;
04198
04199
04200 typeflag(sc->NIL) = (T_ATOM | MARK);
04201 car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
04202
04203 typeflag(sc->T) = (T_ATOM | MARK);
04204 car(sc->T) = cdr(sc->T) = sc->T;
04205
04206 typeflag(sc->F) = (T_ATOM | MARK);
04207 car(sc->F) = cdr(sc->F) = sc->F;
04208 sc->oblist = oblist_initial_value(sc);
04209
04210 new_frame_in_env(sc, sc->NIL);
04211 sc->global_env = sc->envir;
04212
04213 x = mk_symbol(sc,"else");
04214 new_slot_in_env(sc, x, sc->T);
04215
04216 assign_syntax(sc, "lambda");
04217 assign_syntax(sc, "quote");
04218 assign_syntax(sc, "define");
04219 assign_syntax(sc, "if");
04220 assign_syntax(sc, "begin");
04221 assign_syntax(sc, "set!");
04222 assign_syntax(sc, "let");
04223 assign_syntax(sc, "let*");
04224 assign_syntax(sc, "letrec");
04225 assign_syntax(sc, "cond");
04226 assign_syntax(sc, "delay");
04227 assign_syntax(sc, "and");
04228 assign_syntax(sc, "or");
04229 assign_syntax(sc, "cons-stream");
04230 assign_syntax(sc, "macro");
04231 assign_syntax(sc, "case");
04232
04233 for(i=0; i<n; i++) {
04234 if(dispatch_table[i].name!=0) {
04235 assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
04236 }
04237 }
04238
04239
04240 sc->LAMBDA = mk_symbol(sc, "lambda");
04241 sc->QUOTE = mk_symbol(sc, "quote");
04242 sc->QQUOTE = mk_symbol(sc, "quasiquote");
04243 sc->UNQUOTE = mk_symbol(sc, "unquote");
04244 sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
04245 sc->FEED_TO = mk_symbol(sc, "=>");
04246 sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
04247 sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
04248 sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
04249
04250 return !sc->no_memory;
04251 }
04252
04253 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
04254 sc->inport=port_from_file(sc,fin,port_input);
04255 }
04256
04257 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
04258 sc->inport=port_from_string(sc,start,past_the_end,port_input);
04259 }
04260
04261 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
04262 sc->outport=port_from_file(sc,fout,port_output);
04263 }
04264
04265 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
04266 sc->outport=port_from_string(sc,start,past_the_end,port_output);
04267 }
04268
04269 void scheme_set_external_data(scheme *sc, void *p) {
04270 sc->ext_data=p;
04271 }
04272
04273 void scheme_deinit(scheme *sc) {
04274 int i;
04275
04276 sc->oblist=sc->NIL;
04277 sc->global_env=sc->NIL;
04278 dump_stack_free(sc);
04279 sc->envir=sc->NIL;
04280 sc->code=sc->NIL;
04281 sc->args=sc->NIL;
04282 sc->value=sc->NIL;
04283 if(is_port(sc->inport)) {
04284 typeflag(sc->inport) = T_ATOM;
04285 }
04286 sc->inport=sc->NIL;
04287 sc->outport=sc->NIL;
04288 if(is_port(sc->save_inport)) {
04289 typeflag(sc->save_inport) = T_ATOM;
04290 }
04291 sc->save_inport=sc->NIL;
04292 if(is_port(sc->loadport)) {
04293 typeflag(sc->loadport) = T_ATOM;
04294 }
04295 sc->loadport=sc->NIL;
04296 sc->gc_verbose=0;
04297 gc(sc,sc->NIL,sc->NIL);
04298
04299 for(i=0; i<=sc->last_cell_seg; i++) {
04300 sc->free(sc->alloc_seg[i]);
04301 }
04302 }
04303
04304 void scheme_load_file(scheme *sc, FILE *fin) {
04305 dump_stack_reset(sc);
04306 sc->envir = sc->global_env;
04307 sc->file_i=0;
04308 sc->load_stack[0].kind=port_input|port_file;
04309 sc->load_stack[0].rep.stdio.file=fin;
04310 sc->loadport=mk_port(sc,sc->load_stack);
04311 sc->retcode=0;
04312 if(fin==stdin) {
04313 sc->interactive_repl=1;
04314 }
04315 sc->inport=sc->loadport;
04316 Eval_Cycle(sc, OP_T0LVL);
04317 typeflag(sc->loadport)=T_ATOM;
04318 if(sc->retcode==0) {
04319 sc->retcode=sc->nesting!=0;
04320 }
04321 }
04322
04323 void scheme_load_string(scheme *sc, const char *cmd) {
04324 dump_stack_reset(sc);
04325 sc->envir = sc->global_env;
04326 sc->file_i=0;
04327 sc->load_stack[0].kind=port_input|port_string;
04328 sc->load_stack[0].rep.string.start=(char*)cmd;
04329 sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
04330 sc->load_stack[0].rep.string.curr=(char*)cmd;
04331 sc->loadport=mk_port(sc,sc->load_stack);
04332 sc->retcode=0;
04333 sc->interactive_repl=0;
04334 sc->inport=sc->loadport;
04335 Eval_Cycle(sc, OP_T0LVL);
04336 typeflag(sc->loadport)=T_ATOM;
04337 if(sc->retcode==0) {
04338 sc->retcode=sc->nesting!=0;
04339 }
04340 }
04341
04342 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
04343 pointer x;
04344
04345 x=find_slot_in_env(sc,envir,symbol,0);
04346 if (x != sc->NIL) {
04347 set_slot_in_env(sc, x, value);
04348 } else {
04349 new_slot_spec_in_env(sc, envir, symbol, value);
04350 }
04351 }
04352
04353 #if !STANDALONE
04354 void scheme_apply0(scheme *sc, const char *procname) {
04355 pointer carx=mk_symbol(sc,procname);
04356 pointer cdrx=sc->NIL;
04357
04358 dump_stack_reset(sc);
04359 sc->envir = sc->global_env;
04360 sc->code = cons(sc,carx,cdrx);
04361 sc->interactive_repl=0;
04362 sc->retcode=0;
04363 Eval_Cycle(sc,OP_EVAL);
04364 }
04365
04366 void scheme_call(scheme *sc, pointer func, pointer args) {
04367 dump_stack_reset(sc);
04368 sc->envir = sc->global_env;
04369 sc->args = args;
04370 sc->code = func;
04371 sc->interactive_repl =0;
04372 sc->retcode = 0;
04373 Eval_Cycle(sc, OP_APPLY);
04374 }
04375 #endif
04376
04377
04378
04379 #if STANDALONE
04380
04381 #ifdef macintosh
04382 int main()
04383 {
04384 extern MacTS_main(int argc, char **argv);
04385 char** argv;
04386 int argc = ccommand(&argv);
04387 MacTS_main(argc,argv);
04388 return 0;
04389 }
04390 int MacTS_main(int argc, char **argv) {
04391 #else
04392 int main(int argc, char **argv) {
04393 #endif
04394 scheme sc;
04395 FILE *fin = 0;
04396 char *file_name=InitFile;
04397 int retcode;
04398 int isfile=1;
04399
04400 if(argc==1) {
04401 printf(banner);
04402 }
04403 if(argc==2 && strcmp(argv[1],"-?")==0) {
04404 printf("Usage: %s [-? | <file1> <file2> ... | -1 <file> <arg1> <arg2> ...]\n\tUse - as filename for stdin.\n",argv[0]);
04405 return 1;
04406 }
04407 if(!scheme_init(&sc)) {
04408 fprintf(stderr,"Could not initialize!\n");
04409 return 2;
04410 }
04411 scheme_set_input_port_file(&sc, stdin);
04412 scheme_set_output_port_file(&sc, stdout);
04413 #if USE_DL
04414 scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
04415 #endif
04416 argv++;
04417 if(access(file_name,0)!=0) {
04418 char *p=getenv("TINYSCHEMEINIT");
04419 if(p!=0) {
04420 file_name=p;
04421 }
04422 }
04423 do {
04424 if(strcmp(file_name,"-")==0) {
04425 fin=stdin;
04426 } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
04427 pointer args=sc.NIL;
04428 isfile=file_name[1]=='1';
04429 file_name=*argv++;
04430 if(strcmp(file_name,"-")==0) {
04431 fin=stdin;
04432 } else if(isfile) {
04433 fin=fopen(file_name,"r");
04434 }
04435 for(;*argv;argv++) {
04436 pointer value=mk_string(&sc,*argv);
04437 args=cons(&sc,value,args);
04438 }
04439 args=reverse_in_place(&sc,sc.NIL,args);
04440 scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
04441
04442 } else {
04443 fin=fopen(file_name,"r");
04444 }
04445 if(isfile && fin==0) {
04446 fprintf(stderr,"Could not open file %s\n",file_name);
04447 } else {
04448 if(isfile) {
04449 scheme_load_file(&sc,fin);
04450 } else {
04451 scheme_load_string(&sc,file_name);
04452 }
04453 if(!isfile || fin!=stdin) {
04454 if(sc.retcode!=0) {
04455 fprintf(stderr,"Errors encountered reading %s\n",file_name);
04456 }
04457 if(isfile) {
04458 fclose(fin);
04459 }
04460 }
04461 }
04462 file_name=*argv++;
04463 } while(file_name!=0);
04464 if(argc==1) {
04465 scheme_load_file(&sc,stdin);
04466 }
04467 retcode=sc.retcode;
04468 scheme_deinit(&sc);
04469
04470 return retcode;
04471 }
04472
04473 #endif
