-
+ B9F2C8885474FD6B4F7D36955799716E68161BE8F8CFCE3640ADE942FE0064A00D64C7DABC3EC36B24797760B99EA6C79D74A8F984DCC3AEAC2EEF183B3ED70Bbitcoin/src/shiva/scheme.c(0 . 0)(1 . 5023)
2234 /*
2235 This version de-crudded for therealbitcoin.org.
2236 Applied interactive REPL fixups for port redirect mode.
2237 */
2238
2239 /* T I N Y S C H E M E 1 . 4 1
2240 * Dimitrios Souflis (dsouflis@acm.org)
2241 * Based on MiniScheme (original credits follow)
2242 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
2243 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
2244 * (MINISCM) This version has been modified by R.C. Secrist.
2245 * (MINISCM)
2246 * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
2247 * (MINISCM)
2248 * (MINISCM) This is a revised and modified version by Akira KIDA.
2249 * (MINISCM) current version is 0.85k4 (15 May 1994)
2250 *
2251 */
2252
2253 #define _SCHEME_SOURCE
2254 #include "scheme-knobs.h"
2255 #include "scheme-private.h"
2256
2257 #include <unistd.h>
2258 #include <sys/types.h>
2259
2260 #if USE_MATH
2261 # include <math.h>
2262 #endif
2263
2264 #include <limits.h>
2265 #include <float.h>
2266 #include <ctype.h>
2267
2268 #if USE_STRCASECMP
2269 #include <strings.h>
2270 #define stricmp strcasecmp
2271 #endif
2272
2273 const char* tiny_scheme_version = PACKAGE_VERSION;
2274
2275 /* Used for documentation purposes, to signal functions in 'interface' */
2276 #define INTERFACE
2277
2278 #define TOK_EOF (-1)
2279 #define TOK_LPAREN 0
2280 #define TOK_RPAREN 1
2281 #define TOK_DOT 2
2282 #define TOK_ATOM 3
2283 #define TOK_QUOTE 4
2284 #define TOK_COMMENT 5
2285 #define TOK_DQUOTE 6
2286 #define TOK_BQUOTE 7
2287 #define TOK_COMMA 8
2288 #define TOK_ATMARK 9
2289 #define TOK_SHARP 10
2290 #define TOK_SHARP_CONST 11
2291 #define TOK_VEC 12
2292
2293 #define BACKQUOTE '`'
2294 #define DELIMITERS "()\";\f\t\v\n\r "
2295
2296 /*
2297 * Basic memory allocation units
2298 */
2299
2300 #define banner "TinyScheme 1.41"
2301
2302 #include <string.h>
2303 #include <stdlib.h>
2304
2305 #if USE_STRLWR
2306 static const char *strlwr(char *s) {
2307 const char *p=s;
2308 while(*s) {
2309 *s=tolower(*s);
2310 s++;
2311 }
2312 return p;
2313 }
2314 #endif
2315
2316 #ifndef prompt
2317 # define prompt "ts> "
2318 #endif
2319
2320 #ifndef InitFile
2321 # define InitFile "init.scm"
2322 #endif
2323
2324 #ifndef FIRST_CELLSEGS
2325 # define FIRST_CELLSEGS 3
2326 #endif
2327
2328 enum scheme_types {
2329 T_STRING=1,
2330 T_NUMBER=2,
2331 T_SYMBOL=3,
2332 T_PROC=4,
2333 T_PAIR=5,
2334 T_CLOSURE=6,
2335 T_CONTINUATION=7,
2336 T_FOREIGN=8,
2337 T_CHARACTER=9,
2338 T_PORT=10,
2339 T_VECTOR=11,
2340 T_MACRO=12,
2341 T_PROMISE=13,
2342 T_ENVIRONMENT=14,
2343 T_LAST_SYSTEM_TYPE=14
2344 };
2345
2346 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
2347 #define ADJ 32
2348 #define TYPE_BITS 5
2349 #define T_MASKTYPE 31 /* 0000000000011111 */
2350 #define T_SYNTAX 4096 /* 0001000000000000 */
2351 #define T_IMMUTABLE 8192 /* 0010000000000000 */
2352 #define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
2353 #define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
2354 #define MARK 32768 /* 1000000000000000 */
2355 #define UNMARK 32767 /* 0111111111111111 */
2356
2357
2358 static num num_add(num a, num b);
2359 static num num_mul(num a, num b);
2360 static num num_div(num a, num b);
2361 static num num_intdiv(num a, num b);
2362 static num num_sub(num a, num b);
2363 static num num_rem(num a, num b);
2364 static num num_mod(num a, num b);
2365 static int num_eq(num a, num b);
2366 static int num_gt(num a, num b);
2367 static int num_ge(num a, num b);
2368 static int num_lt(num a, num b);
2369 static int num_le(num a, num b);
2370
2371 #if USE_MATH
2372 static double round_per_R5RS(double x);
2373 #endif
2374 static int is_zero_double(double x);
2375 static INLINE int num_is_integer(pointer p) {
2376 return ((p)->_object._number.is_fixnum);
2377 }
2378
2379 static num num_zero;
2380 static num num_one;
2381
2382 /* macros for cell operations */
2383 #define typeflag(p) ((p)->_flag)
2384 #define type(p) (typeflag(p)&T_MASKTYPE)
2385
2386 INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
2387 #define strvalue(p) ((p)->_object._string._svalue)
2388 #define strlength(p) ((p)->_object._string._length)
2389
2390 INTERFACE static int is_list(scheme *sc, pointer p);
2391 INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
2392 INTERFACE static void fill_vector(pointer vec, pointer obj);
2393 INTERFACE static pointer vector_elem(pointer vec, int ielem);
2394 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
2395 INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
2396 INTERFACE INLINE int is_integer(pointer p) {
2397 if (!is_number(p))
2398 return 0;
2399 if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
2400 return 1;
2401 return 0;
2402 }
2403
2404 INTERFACE INLINE int is_real(pointer p) {
2405 return is_number(p) && (!(p)->_object._number.is_fixnum);
2406 }
2407
2408 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
2409 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
2410 INLINE num nvalue(pointer p) { return ((p)->_object._number); }
2411 INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
2412 INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
2413 #define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
2414 #define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
2415 #define set_num_integer(p) (p)->_object._number.is_fixnum=1;
2416 #define set_num_real(p) (p)->_object._number.is_fixnum=0;
2417 INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); }
2418
2419 INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
2420 INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; }
2421 INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
2422
2423 INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
2424 #define car(p) ((p)->_object._cons._car)
2425 #define cdr(p) ((p)->_object._cons._cdr)
2426 INTERFACE pointer pair_car(pointer p) { return car(p); }
2427 INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
2428 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
2429 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
2430
2431 INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
2432 INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
2433 #if USE_PLIST
2434 SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
2435 #define symprop(p) cdr(p)
2436 #endif
2437
2438 INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
2439 INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
2440 INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
2441 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
2442 #define procnum(p) ivalue(p)
2443 static const char *procname(pointer x);
2444
2445 INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
2446 INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
2447 INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
2448 INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
2449
2450 INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
2451 #define cont_dump(p) cdr(p)
2452
2453 /* To do: promise should be forced ONCE only */
2454 INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
2455
2456 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
2457 #define setenvironment(p) typeflag(p) = T_ENVIRONMENT
2458
2459 #define is_atom(p) (typeflag(p)&T_ATOM)
2460 #define setatom(p) typeflag(p) |= T_ATOM
2461 #define clratom(p) typeflag(p) &= CLRATOM
2462
2463 #define is_mark(p) (typeflag(p)&MARK)
2464 #define setmark(p) typeflag(p) |= MARK
2465 #define clrmark(p) typeflag(p) &= UNMARK
2466
2467 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
2468 /*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
2469 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
2470
2471 #define caar(p) car(car(p))
2472 #define cadr(p) car(cdr(p))
2473 #define cdar(p) cdr(car(p))
2474 #define cddr(p) cdr(cdr(p))
2475 #define cadar(p) car(cdr(car(p)))
2476 #define caddr(p) car(cdr(cdr(p)))
2477 #define cdaar(p) cdr(car(car(p)))
2478 #define cadaar(p) car(cdr(car(car(p))))
2479 #define cadddr(p) car(cdr(cdr(cdr(p))))
2480 #define cddddr(p) cdr(cdr(cdr(cdr(p))))
2481
2482 #if USE_CHAR_CLASSIFIERS
2483 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
2484 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
2485 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
2486 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
2487 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
2488 #endif
2489
2490 #if USE_ASCII_NAMES
2491 static const char *charnames[32]={
2492 "nul",
2493 "soh",
2494 "stx",
2495 "etx",
2496 "eot",
2497 "enq",
2498 "ack",
2499 "bel",
2500 "bs",
2501 "ht",
2502 "lf",
2503 "vt",
2504 "ff",
2505 "cr",
2506 "so",
2507 "si",
2508 "dle",
2509 "dc1",
2510 "dc2",
2511 "dc3",
2512 "dc4",
2513 "nak",
2514 "syn",
2515 "etb",
2516 "can",
2517 "em",
2518 "sub",
2519 "esc",
2520 "fs",
2521 "gs",
2522 "rs",
2523 "us"
2524 };
2525
2526 static int is_ascii_name(const char *name, int *pc) {
2527 int i;
2528 for(i=0; i<32; i++) {
2529 if(stricmp(name,charnames[i])==0) {
2530 *pc=i;
2531 return 1;
2532 }
2533 }
2534 if(stricmp(name,"del")==0) {
2535 *pc=127;
2536 return 1;
2537 }
2538 return 0;
2539 }
2540
2541 #endif
2542
2543 static int file_push(scheme *sc, const char *fname);
2544 static void file_pop(scheme *sc);
2545 static int file_interactive(scheme *sc);
2546 static INLINE int is_one_of(char *s, int c);
2547 static int alloc_cellseg(scheme *sc, int n);
2548 static long binary_decode(const char *s);
2549 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
2550 static pointer _get_cell(scheme *sc, pointer a, pointer b);
2551 static pointer reserve_cells(scheme *sc, int n);
2552 static pointer get_consecutive_cells(scheme *sc, int n);
2553 static pointer find_consecutive_cells(scheme *sc, int n);
2554 static void finalize_cell(scheme *sc, pointer a);
2555 static int count_consecutive_cells(pointer x, int needed);
2556 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
2557 static pointer mk_number(scheme *sc, num n);
2558 static char *store_string(scheme *sc, int len, const char *str, char fill);
2559 static pointer mk_vector(scheme *sc, int len);
2560 static pointer mk_atom(scheme *sc, char *q);
2561 static pointer mk_sharp_const(scheme *sc, char *name);
2562 static pointer mk_port(scheme *sc, port *p);
2563 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
2564 static pointer port_from_file(scheme *sc, FILE *, int prop);
2565 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
2566 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
2567 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
2568 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
2569 static void port_close(scheme *sc, pointer p, int flag);
2570 static void mark(pointer a);
2571 static void gc(scheme *sc, pointer a, pointer b);
2572 static int basic_inchar(port *pt);
2573 static int inchar(scheme *sc);
2574 static void backchar(scheme *sc, int c);
2575 static char *readstr_upto(scheme *sc, char *delim);
2576 static pointer readstrexp(scheme *sc);
2577 static INLINE int skipspace(scheme *sc);
2578 static int token(scheme *sc);
2579 static void printslashstring(scheme *sc, char *s, int len);
2580 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
2581 static void printatom(scheme *sc, pointer l, int f);
2582 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
2583 static pointer mk_closure(scheme *sc, pointer c, pointer e);
2584 static pointer mk_continuation(scheme *sc, pointer d);
2585 static pointer reverse(scheme *sc, pointer a);
2586 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
2587 static pointer revappend(scheme *sc, pointer a, pointer b);
2588 static void dump_stack_mark(scheme *);
2589 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
2590 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
2591 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
2592 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
2593 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
2594 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
2595 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
2596 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
2597 static void assign_syntax(scheme *sc, char *name);
2598 static int syntaxnum(pointer p);
2599 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
2600
2601 #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
2602 #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
2603
2604 static num num_add(num a, num b) {
2605 num ret;
2606 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2607 if(ret.is_fixnum) {
2608 ret.value.ivalue= a.value.ivalue+b.value.ivalue;
2609 } else {
2610 ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
2611 }
2612 return ret;
2613 }
2614
2615 static num num_mul(num a, num b) {
2616 num ret;
2617 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2618 if(ret.is_fixnum) {
2619 ret.value.ivalue= a.value.ivalue*b.value.ivalue;
2620 } else {
2621 ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
2622 }
2623 return ret;
2624 }
2625
2626 static num num_div(num a, num b) {
2627 num ret;
2628 ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
2629 if(ret.is_fixnum) {
2630 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
2631 } else {
2632 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
2633 }
2634 return ret;
2635 }
2636
2637 static num num_intdiv(num a, num b) {
2638 num ret;
2639 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2640 if(ret.is_fixnum) {
2641 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
2642 } else {
2643 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
2644 }
2645 return ret;
2646 }
2647
2648 static num num_sub(num a, num b) {
2649 num ret;
2650 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2651 if(ret.is_fixnum) {
2652 ret.value.ivalue= a.value.ivalue-b.value.ivalue;
2653 } else {
2654 ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
2655 }
2656 return ret;
2657 }
2658
2659 static num num_rem(num a, num b) {
2660 num ret;
2661 long e1, e2, res;
2662 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2663 e1=num_ivalue(a);
2664 e2=num_ivalue(b);
2665 res=e1%e2;
2666 /* remainder should have same sign as second operand */
2667 if (res > 0) {
2668 if (e1 < 0) {
2669 res -= labs(e2);
2670 }
2671 } else if (res < 0) {
2672 if (e1 > 0) {
2673 res += labs(e2);
2674 }
2675 }
2676 ret.value.ivalue=res;
2677 return ret;
2678 }
2679
2680 static num num_mod(num a, num b) {
2681 num ret;
2682 long e1, e2, res;
2683 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
2684 e1=num_ivalue(a);
2685 e2=num_ivalue(b);
2686 res=e1%e2;
2687 /* modulo should have same sign as second operand */
2688 if (res * e2 < 0) {
2689 res += e2;
2690 }
2691 ret.value.ivalue=res;
2692 return ret;
2693 }
2694
2695 static int num_eq(num a, num b) {
2696 int ret;
2697 int is_fixnum=a.is_fixnum && b.is_fixnum;
2698 if(is_fixnum) {
2699 ret= a.value.ivalue==b.value.ivalue;
2700 } else {
2701 ret=num_rvalue(a)==num_rvalue(b);
2702 }
2703 return ret;
2704 }
2705
2706
2707 static int num_gt(num a, num b) {
2708 int ret;
2709 int is_fixnum=a.is_fixnum && b.is_fixnum;
2710 if(is_fixnum) {
2711 ret= a.value.ivalue>b.value.ivalue;
2712 } else {
2713 ret=num_rvalue(a)>num_rvalue(b);
2714 }
2715 return ret;
2716 }
2717
2718 static int num_ge(num a, num b) {
2719 return !num_lt(a,b);
2720 }
2721
2722 static int num_lt(num a, num b) {
2723 int ret;
2724 int is_fixnum=a.is_fixnum && b.is_fixnum;
2725 if(is_fixnum) {
2726 ret= a.value.ivalue<b.value.ivalue;
2727 } else {
2728 ret=num_rvalue(a)<num_rvalue(b);
2729 }
2730 return ret;
2731 }
2732
2733 static int num_le(num a, num b) {
2734 return !num_gt(a,b);
2735 }
2736
2737 #if USE_MATH
2738 /* Round to nearest. Round to even if midway */
2739 static double round_per_R5RS(double x) {
2740 double fl=floor(x);
2741 double ce=ceil(x);
2742 double dfl=x-fl;
2743 double dce=ce-x;
2744 if(dfl>dce) {
2745 return ce;
2746 } else if(dfl<dce) {
2747 return fl;
2748 } else {
2749 if(fmod(fl,2.0)==0.0) { /* I imagine this holds */
2750 return fl;
2751 } else {
2752 return ce;
2753 }
2754 }
2755 }
2756 #endif
2757
2758 static int is_zero_double(double x) {
2759 return x<DBL_MIN && x>-DBL_MIN;
2760 }
2761
2762 static long binary_decode(const char *s) {
2763 long x=0;
2764
2765 while(*s!=0 && (*s=='1' || *s=='0')) {
2766 x<<=1;
2767 x+=*s-'0';
2768 s++;
2769 }
2770
2771 return x;
2772 }
2773
2774 /* allocate new cell segment */
2775 static int alloc_cellseg(scheme *sc, int n) {
2776 pointer newp;
2777 pointer last;
2778 pointer p;
2779 char *cp;
2780 long i;
2781 int k;
2782 int adj=ADJ;
2783
2784 if(adj<sizeof(struct cell)) {
2785 adj=sizeof(struct cell);
2786 }
2787
2788 for (k = 0; k < n; k++) {
2789 if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
2790 return k;
2791 cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
2792 if (cp == 0)
2793 return k;
2794 i = ++sc->last_cell_seg ;
2795 sc->alloc_seg[i] = cp;
2796 /* adjust in TYPE_BITS-bit boundary */
2797 if(((unsigned long)cp)%adj!=0) {
2798 cp=(char*)(adj*((unsigned long)cp/adj+1));
2799 }
2800 /* insert new segment in address order */
2801 newp=(pointer)cp;
2802 sc->cell_seg[i] = newp;
2803 while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
2804 p = sc->cell_seg[i];
2805 sc->cell_seg[i] = sc->cell_seg[i - 1];
2806 sc->cell_seg[--i] = p;
2807 }
2808 sc->fcells += CELL_SEGSIZE;
2809 last = newp + CELL_SEGSIZE - 1;
2810 for (p = newp; p <= last; p++) {
2811 typeflag(p) = 0;
2812 cdr(p) = p + 1;
2813 car(p) = sc->NIL;
2814 }
2815 /* insert new cells in address order on free list */
2816 if (sc->free_cell == sc->NIL || p < sc->free_cell) {
2817 cdr(last) = sc->free_cell;
2818 sc->free_cell = newp;
2819 } else {
2820 p = sc->free_cell;
2821 while (cdr(p) != sc->NIL && newp > cdr(p))
2822 p = cdr(p);
2823 cdr(last) = cdr(p);
2824 cdr(p) = newp;
2825 }
2826 }
2827 return n;
2828 }
2829
2830 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
2831 if (sc->free_cell != sc->NIL) {
2832 pointer x = sc->free_cell;
2833 sc->free_cell = cdr(x);
2834 --sc->fcells;
2835 return (x);
2836 }
2837 return _get_cell (sc, a, b);
2838 }
2839
2840
2841 /* get new cell. parameter a, b is marked by gc. */
2842 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
2843 pointer x;
2844
2845 if(sc->no_memory) {
2846 return sc->sink;
2847 }
2848
2849 if (sc->free_cell == sc->NIL) {
2850 const int min_to_be_recovered = sc->last_cell_seg*8;
2851 gc(sc,a, b);
2852 if (sc->fcells < min_to_be_recovered
2853 || sc->free_cell == sc->NIL) {
2854 /* if only a few recovered, get more to avoid fruitless gc's */
2855 if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
2856 sc->no_memory=1;
2857 return sc->sink;
2858 }
2859 }
2860 }
2861 x = sc->free_cell;
2862 sc->free_cell = cdr(x);
2863 --sc->fcells;
2864 return (x);
2865 }
2866
2867 /* make sure that there is a given number of cells free */
2868 static pointer reserve_cells(scheme *sc, int n) {
2869 if(sc->no_memory) {
2870 return sc->NIL;
2871 }
2872
2873 /* Are there enough cells available? */
2874 if (sc->fcells < n) {
2875 /* If not, try gc'ing some */
2876 gc(sc, sc->NIL, sc->NIL);
2877 if (sc->fcells < n) {
2878 /* If there still aren't, try getting more heap */
2879 if (!alloc_cellseg(sc,1)) {
2880 sc->no_memory=1;
2881 return sc->NIL;
2882 }
2883 }
2884 if (sc->fcells < n) {
2885 /* If all fail, report failure */
2886 sc->no_memory=1;
2887 return sc->NIL;
2888 }
2889 }
2890 return (sc->T);
2891 }
2892
2893 static pointer get_consecutive_cells(scheme *sc, int n) {
2894 pointer x;
2895
2896 if(sc->no_memory) { return sc->sink; }
2897
2898 /* Are there any cells available? */
2899 x=find_consecutive_cells(sc,n);
2900 if (x != sc->NIL) { return x; }
2901
2902 /* If not, try gc'ing some */
2903 gc(sc, sc->NIL, sc->NIL);
2904 x=find_consecutive_cells(sc,n);
2905 if (x != sc->NIL) { return x; }
2906
2907 /* If there still aren't, try getting more heap */
2908 if (!alloc_cellseg(sc,1))
2909 {
2910 sc->no_memory=1;
2911 return sc->sink;
2912 }
2913
2914 x=find_consecutive_cells(sc,n);
2915 if (x != sc->NIL) { return x; }
2916
2917 /* If all fail, report failure */
2918 sc->no_memory=1;
2919 return sc->sink;
2920 }
2921
2922 static int count_consecutive_cells(pointer x, int needed) {
2923 int n=1;
2924 while(cdr(x)==x+1) {
2925 x=cdr(x);
2926 n++;
2927 if(n>needed) return n;
2928 }
2929 return n;
2930 }
2931
2932 static pointer find_consecutive_cells(scheme *sc, int n) {
2933 pointer *pp;
2934 int cnt;
2935
2936 pp=&sc->free_cell;
2937 while(*pp!=sc->NIL) {
2938 cnt=count_consecutive_cells(*pp,n);
2939 if(cnt>=n) {
2940 pointer x=*pp;
2941 *pp=cdr(*pp+n-1);
2942 sc->fcells -= n;
2943 return x;
2944 }
2945 pp=&cdr(*pp+cnt-1);
2946 }
2947 return sc->NIL;
2948 }
2949
2950 /* To retain recent allocs before interpreter knows about them -
2951 Tehom */
2952
2953 static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
2954 {
2955 pointer holder = get_cell_x(sc, recent, extra);
2956 typeflag(holder) = T_PAIR | T_IMMUTABLE;
2957 car(holder) = recent;
2958 cdr(holder) = car(sc->sink);
2959 car(sc->sink) = holder;
2960 }
2961
2962
2963 static pointer get_cell(scheme *sc, pointer a, pointer b)
2964 {
2965 pointer cell = get_cell_x(sc, a, b);
2966 /* For right now, include "a" and "b" in "cell" so that gc doesn't
2967 think they are garbage. */
2968 /* Tentatively record it as a pair so gc understands it. */
2969 typeflag(cell) = T_PAIR;
2970 car(cell) = a;
2971 cdr(cell) = b;
2972 push_recent_alloc(sc, cell, sc->NIL);
2973 return cell;
2974 }
2975
2976 static pointer get_vector_object(scheme *sc, int len, pointer init)
2977 {
2978 pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
2979 if(sc->no_memory) { return sc->sink; }
2980 /* Record it as a vector so that gc understands it. */
2981 typeflag(cells) = (T_VECTOR | T_ATOM);
2982 ivalue_unchecked(cells)=len;
2983 set_num_integer(cells);
2984 fill_vector(cells,init);
2985 push_recent_alloc(sc, cells, sc->NIL);
2986 return cells;
2987 }
2988
2989 static INLINE void ok_to_freely_gc(scheme *sc)
2990 {
2991 car(sc->sink) = sc->NIL;
2992 }
2993
2994
2995 #if defined TSGRIND
2996 static void check_cell_alloced(pointer p, int expect_alloced)
2997 {
2998 /* Can't use putstr(sc,str) because callers have no access to
2999 sc. */
3000 if(typeflag(p) & !expect_alloced)
3001 {
3002 fprintf(stderr,"Cell is already allocated!\n");
3003 }
3004 if(!(typeflag(p)) & expect_alloced)
3005 {
3006 fprintf(stderr,"Cell is not allocated!\n");
3007 }
3008
3009 }
3010 static void check_range_alloced(pointer p, int n, int expect_alloced)
3011 {
3012 int i;
3013 for(i = 0;i<n;i++)
3014 { (void)check_cell_alloced(p+i,expect_alloced); }
3015 }
3016
3017 #endif
3018
3019 /* Medium level cell allocation */
3020
3021 /* get new cons cell */
3022 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
3023 pointer x = get_cell(sc,a, b);
3024
3025 typeflag(x) = T_PAIR;
3026 if(immutable) {
3027 setimmutable(x);
3028 }
3029 car(x) = a;
3030 cdr(x) = b;
3031 return (x);
3032 }
3033
3034 /* ========== oblist implementation ========== */
3035
3036 #ifndef USE_OBJECT_LIST
3037
3038 static int hash_fn(const char *key, int table_size);
3039
3040 static pointer oblist_initial_value(scheme *sc)
3041 {
3042 return mk_vector(sc, 461); /* probably should be bigger */
3043 }
3044
3045 /* returns the new symbol */
3046 static pointer oblist_add_by_name(scheme *sc, const char *name)
3047 {
3048 pointer x;
3049 int location;
3050
3051 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
3052 typeflag(x) = T_SYMBOL;
3053 setimmutable(car(x));
3054
3055 location = hash_fn(name, ivalue_unchecked(sc->oblist));
3056 set_vector_elem(sc->oblist, location,
3057 immutable_cons(sc, x, vector_elem(sc->oblist, location)));
3058 return x;
3059 }
3060
3061 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
3062 {
3063 int location;
3064 pointer x;
3065 char *s;
3066
3067 location = hash_fn(name, ivalue_unchecked(sc->oblist));
3068 for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
3069 s = symname(car(x));
3070 /* case-insensitive, per R5RS section 2. */
3071 if(stricmp(name, s) == 0) {
3072 return car(x);
3073 }
3074 }
3075 return sc->NIL;
3076 }
3077
3078 static pointer oblist_all_symbols(scheme *sc)
3079 {
3080 int i;
3081 pointer x;
3082 pointer ob_list = sc->NIL;
3083
3084 for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
3085 for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
3086 ob_list = cons(sc, x, ob_list);
3087 }
3088 }
3089 return ob_list;
3090 }
3091
3092 #else
3093
3094 static pointer oblist_initial_value(scheme *sc)
3095 {
3096 return sc->NIL;
3097 }
3098
3099 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
3100 {
3101 pointer x;
3102 char *s;
3103
3104 for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
3105 s = symname(car(x));
3106 /* case-insensitive, per R5RS section 2. */
3107 if(stricmp(name, s) == 0) {
3108 return car(x);
3109 }
3110 }
3111 return sc->NIL;
3112 }
3113
3114 /* returns the new symbol */
3115 static pointer oblist_add_by_name(scheme *sc, const char *name)
3116 {
3117 pointer x;
3118
3119 x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
3120 typeflag(x) = T_SYMBOL;
3121 setimmutable(car(x));
3122 sc->oblist = immutable_cons(sc, x, sc->oblist);
3123 return x;
3124 }
3125 static pointer oblist_all_symbols(scheme *sc)
3126 {
3127 return sc->oblist;
3128 }
3129
3130 #endif
3131
3132 static pointer mk_port(scheme *sc, port *p) {
3133 pointer x = get_cell(sc, sc->NIL, sc->NIL);
3134
3135 typeflag(x) = T_PORT|T_ATOM;
3136 x->_object._port=p;
3137 return (x);
3138 }
3139
3140 pointer mk_foreign_func(scheme *sc, foreign_func f) {
3141 pointer x = get_cell(sc, sc->NIL, sc->NIL);
3142
3143 typeflag(x) = (T_FOREIGN | T_ATOM);
3144 x->_object._ff=f;
3145 return (x);
3146 }
3147
3148 INTERFACE pointer mk_character(scheme *sc, int c) {
3149 pointer x = get_cell(sc,sc->NIL, sc->NIL);
3150
3151 typeflag(x) = (T_CHARACTER | T_ATOM);
3152 ivalue_unchecked(x)= c;
3153 set_num_integer(x);
3154 return (x);
3155 }
3156
3157 /* get number atom (integer) */
3158 INTERFACE pointer mk_integer(scheme *sc, long num) {
3159 pointer x = get_cell(sc,sc->NIL, sc->NIL);
3160
3161 typeflag(x) = (T_NUMBER | T_ATOM);
3162 ivalue_unchecked(x)= num;
3163 set_num_integer(x);
3164 return (x);
3165 }
3166
3167 INTERFACE pointer mk_real(scheme *sc, double n) {
3168 pointer x = get_cell(sc,sc->NIL, sc->NIL);
3169
3170 typeflag(x) = (T_NUMBER | T_ATOM);
3171 rvalue_unchecked(x)= n;
3172 set_num_real(x);
3173 return (x);
3174 }
3175
3176 static pointer mk_number(scheme *sc, num n) {
3177 if(n.is_fixnum) {
3178 return mk_integer(sc,n.value.ivalue);
3179 } else {
3180 return mk_real(sc,n.value.rvalue);
3181 }
3182 }
3183
3184 /* allocate name to string area */
3185 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
3186 char *q;
3187
3188 q=(char*)sc->malloc(len_str+1);
3189 if(q==0) {
3190 sc->no_memory=1;
3191 return sc->strbuff;
3192 }
3193 if(str!=0) {
3194 snprintf(q, len_str+1, "%s", str);
3195 } else {
3196 memset(q, fill, len_str);
3197 q[len_str]=0;
3198 }
3199 return (q);
3200 }
3201
3202 /* get new string */
3203 INTERFACE pointer mk_string(scheme *sc, const char *str) {
3204 return mk_counted_string(sc,str,strlen(str));
3205 }
3206
3207 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
3208 pointer x = get_cell(sc, sc->NIL, sc->NIL);
3209 typeflag(x) = (T_STRING | T_ATOM);
3210 strvalue(x) = store_string(sc,len,str,0);
3211 strlength(x) = len;
3212 return (x);
3213 }
3214
3215 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
3216 pointer x = get_cell(sc, sc->NIL, sc->NIL);
3217 typeflag(x) = (T_STRING | T_ATOM);
3218 strvalue(x) = store_string(sc,len,0,fill);
3219 strlength(x) = len;
3220 return (x);
3221 }
3222
3223 INTERFACE static pointer mk_vector(scheme *sc, int len)
3224 { return get_vector_object(sc,len,sc->NIL); }
3225
3226 INTERFACE static void fill_vector(pointer vec, pointer obj) {
3227 int i;
3228 int num=ivalue(vec)/2+ivalue(vec)%2;
3229 for(i=0; i<num; i++) {
3230 typeflag(vec+1+i) = T_PAIR;
3231 setimmutable(vec+1+i);
3232 car(vec+1+i)=obj;
3233 cdr(vec+1+i)=obj;
3234 }
3235 }
3236
3237 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
3238 int n=ielem/2;
3239 if(ielem%2==0) {
3240 return car(vec+1+n);
3241 } else {
3242 return cdr(vec+1+n);
3243 }
3244 }
3245
3246 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
3247 int n=ielem/2;
3248 if(ielem%2==0) {
3249 return car(vec+1+n)=a;
3250 } else {
3251 return cdr(vec+1+n)=a;
3252 }
3253 }
3254
3255 /* get new symbol */
3256 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
3257 pointer x;
3258
3259 /* first check oblist */
3260 x = oblist_find_by_name(sc, name);
3261 if (x != sc->NIL) {
3262 return (x);
3263 } else {
3264 x = oblist_add_by_name(sc, name);
3265 return (x);
3266 }
3267 }
3268
3269 INTERFACE pointer gensym(scheme *sc) {
3270 pointer x;
3271 char name[40];
3272
3273 for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
3274 snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
3275
3276 /* first check oblist */
3277 x = oblist_find_by_name(sc, name);
3278
3279 if (x != sc->NIL) {
3280 continue;
3281 } else {
3282 x = oblist_add_by_name(sc, name);
3283 return (x);
3284 }
3285 }
3286
3287 return sc->NIL;
3288 }
3289
3290 /* make symbol or number atom from string */
3291 static pointer mk_atom(scheme *sc, char *q) {
3292 char c, *p;
3293 int has_dec_point=0;
3294 int has_fp_exp = 0;
3295
3296 #if USE_COLON_HOOK
3297 if((p=strstr(q,"::"))!=0) {
3298 *p=0;
3299 return cons(sc, sc->COLON_HOOK,
3300 cons(sc,
3301 cons(sc,
3302 sc->QUOTE,
3303 cons(sc, mk_atom(sc,p+2), sc->NIL)),
3304 cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
3305 }
3306 #endif
3307
3308 p = q;
3309 c = *p++;
3310 if ((c == '+') || (c == '-')) {
3311 c = *p++;
3312 if (c == '.') {
3313 has_dec_point=1;
3314 c = *p++;
3315 }
3316 if (!isdigit(c)) {
3317 return (mk_symbol(sc, strlwr(q)));
3318 }
3319 } else if (c == '.') {
3320 has_dec_point=1;
3321 c = *p++;
3322 if (!isdigit(c)) {
3323 return (mk_symbol(sc, strlwr(q)));
3324 }
3325 } else if (!isdigit(c)) {
3326 return (mk_symbol(sc, strlwr(q)));
3327 }
3328
3329 for ( ; (c = *p) != 0; ++p) {
3330 if (!isdigit(c)) {
3331 if(c=='.') {
3332 if(!has_dec_point) {
3333 has_dec_point=1;
3334 continue;
3335 }
3336 }
3337 else if ((c == 'e') || (c == 'E')) {
3338 if(!has_fp_exp) {
3339 has_dec_point = 1; /* decimal point illegal
3340 from now on */
3341 p++;
3342 if ((*p == '-') || (*p == '+') || isdigit(*p)) {
3343 continue;
3344 }
3345 }
3346 }
3347 return (mk_symbol(sc, strlwr(q)));
3348 }
3349 }
3350 if(has_dec_point) {
3351 return mk_real(sc,atof(q));
3352 }
3353 return (mk_integer(sc, atol(q)));
3354 }
3355
3356 /* make constant */
3357 static pointer mk_sharp_const(scheme *sc, char *name) {
3358 long x;
3359 char tmp[STRBUFFSIZE];
3360
3361 if (!strcmp(name, "t"))
3362 return (sc->T);
3363 else if (!strcmp(name, "f"))
3364 return (sc->F);
3365 else if (*name == 'o') {/* #o (octal) */
3366 snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
3367 sscanf(tmp, "%lo", (long unsigned *)&x);
3368 return (mk_integer(sc, x));
3369 } else if (*name == 'd') { /* #d (decimal) */
3370 sscanf(name+1, "%ld", (long int *)&x);
3371 return (mk_integer(sc, x));
3372 } else if (*name == 'x') { /* #x (hex) */
3373 snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
3374 sscanf(tmp, "%lx", (long unsigned *)&x);
3375 return (mk_integer(sc, x));
3376 } else if (*name == 'b') { /* #b (binary) */
3377 x = binary_decode(name+1);
3378 return (mk_integer(sc, x));
3379 } else if (*name == '\\') { /* #\w (character) */
3380 int c=0;
3381 if(stricmp(name+1,"space")==0) {
3382 c=' ';
3383 } else if(stricmp(name+1,"newline")==0) {
3384 c='\n';
3385 } else if(stricmp(name+1,"return")==0) {
3386 c='\r';
3387 } else if(stricmp(name+1,"tab")==0) {
3388 c='\t';
3389 } else if(name[1]=='x' && name[2]!=0) {
3390 int c1=0;
3391 if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
3392 c=c1;
3393 } else {
3394 return sc->NIL;
3395 }
3396 #if USE_ASCII_NAMES
3397 } else if(is_ascii_name(name+1,&c)) {
3398 /* nothing */
3399 #endif
3400 } else if(name[2]==0) {
3401 c=name[1];
3402 } else {
3403 return sc->NIL;
3404 }
3405 return mk_character(sc,c);
3406 } else
3407 return (sc->NIL);
3408 }
3409
3410 /* ========== garbage collector ========== */
3411
3412 /*--
3413 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
3414 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
3415 * for marking.
3416 */
3417 static void mark(pointer a) {
3418 pointer t, q, p;
3419
3420 t = (pointer) 0;
3421 p = a;
3422 E2: setmark(p);
3423 if(is_vector(p)) {
3424 int i;
3425 int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
3426 for(i=0; i<num; i++) {
3427 /* Vector cells will be treated like ordinary cells */
3428 mark(p+1+i);
3429 }
3430 }
3431 if (is_atom(p))
3432 goto E6;
3433 /* E4: down car */
3434 q = car(p);
3435 if (q && !is_mark(q)) {
3436 setatom(p); /* a note that we have moved car */
3437 car(p) = t;
3438 t = p;
3439 p = q;
3440 goto E2;
3441 }
3442 E5: q = cdr(p); /* down cdr */
3443 if (q && !is_mark(q)) {
3444 cdr(p) = t;
3445 t = p;
3446 p = q;
3447 goto E2;
3448 }
3449 E6: /* up. Undo the link switching from steps E4 and E5. */
3450 if (!t)
3451 return;
3452 q = t;
3453 if (is_atom(q)) {
3454 clratom(q);
3455 t = car(q);
3456 car(q) = p;
3457 p = q;
3458 goto E5;
3459 } else {
3460 t = cdr(q);
3461 cdr(q) = p;
3462 p = q;
3463 goto E6;
3464 }
3465 }
3466
3467 /* garbage collection. parameter a, b is marked. */
3468 static void gc(scheme *sc, pointer a, pointer b) {
3469 pointer p;
3470 int i;
3471
3472 if(sc->gc_verbose) {
3473 putstr(sc, "gc...");
3474 }
3475
3476 /* mark system globals */
3477 mark(sc->oblist);
3478 mark(sc->global_env);
3479
3480 /* mark current registers */
3481 mark(sc->args);
3482 mark(sc->envir);
3483 mark(sc->code);
3484 dump_stack_mark(sc);
3485 mark(sc->value);
3486 mark(sc->inport);
3487 mark(sc->save_inport);
3488 mark(sc->outport);
3489 mark(sc->loadport);
3490
3491 /* Mark recent objects the interpreter doesn't know about yet. */
3492 mark(car(sc->sink));
3493 /* Mark any older stuff above nested C calls */
3494 mark(sc->c_nest);
3495
3496 /* mark variables a, b */
3497 mark(a);
3498 mark(b);
3499
3500 /* garbage collect */
3501 clrmark(sc->NIL);
3502 sc->fcells = 0;
3503 sc->free_cell = sc->NIL;
3504 /* free-list is kept sorted by address so as to maintain consecutive
3505 ranges, if possible, for use with vectors. Here we scan the cells
3506 (which are also kept sorted by address) downwards to build the
3507 free-list in sorted order.
3508 */
3509 for (i = sc->last_cell_seg; i >= 0; i--) {
3510 p = sc->cell_seg[i] + CELL_SEGSIZE;
3511 while (--p >= sc->cell_seg[i]) {
3512 if (is_mark(p)) {
3513 clrmark(p);
3514 } else {
3515 /* reclaim cell */
3516 if (typeflag(p) != 0) {
3517 finalize_cell(sc, p);
3518 typeflag(p) = 0;
3519 car(p) = sc->NIL;
3520 }
3521 ++sc->fcells;
3522 cdr(p) = sc->free_cell;
3523 sc->free_cell = p;
3524 }
3525 }
3526 }
3527
3528 if (sc->gc_verbose) {
3529 char msg[80];
3530 snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
3531 putstr(sc,msg);
3532 }
3533 }
3534
3535 static void finalize_cell(scheme *sc, pointer a) {
3536 if(is_string(a)) {
3537 sc->free(strvalue(a));
3538 } else if(is_port(a)) {
3539 if(a->_object._port->kind&port_file
3540 && a->_object._port->rep.stdio.closeit) {
3541 port_close(sc,a,port_input|port_output);
3542 }
3543 sc->free(a->_object._port);
3544 }
3545 }
3546
3547 /* ========== Routines for Reading ========== */
3548
3549 static int file_push(scheme *sc, const char *fname) {
3550 FILE *fin = NULL;
3551
3552 if (sc->file_i == MAXFIL-1)
3553 return 0;
3554 fin=fopen(fname,"r");
3555 if(fin!=0) {
3556 sc->file_i++;
3557 sc->load_stack[sc->file_i].kind=port_file|port_input;
3558 sc->load_stack[sc->file_i].rep.stdio.file=fin;
3559 sc->load_stack[sc->file_i].rep.stdio.closeit=1;
3560 sc->nesting_stack[sc->file_i]=0;
3561 sc->loadport->_object._port=sc->load_stack+sc->file_i;
3562
3563 #if SHOW_ERROR_LINE
3564 sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
3565 if(fname)
3566 sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
3567 #endif
3568 }
3569 return fin!=0;
3570 }
3571
3572 static void file_pop(scheme *sc) {
3573 if(sc->file_i != 0) {
3574 sc->nesting=sc->nesting_stack[sc->file_i];
3575 port_close(sc,sc->loadport,port_input);
3576 sc->file_i--;
3577 sc->loadport->_object._port=sc->load_stack+sc->file_i;
3578 }
3579 }
3580
3581 static int file_interactive(scheme *sc) {
3582 return sc->file_i==0 && sc->load_stack[0].rep.stdio.interactive /* sc->load_stack[0].rep.stdio.file==stdin */
3583 && sc->inport->_object._port->kind&port_file;
3584 }
3585
3586 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
3587 FILE *f;
3588 char *rw;
3589 port *pt;
3590 if(prop==(port_input|port_output)) {
3591 rw="a+";
3592 } else if(prop==port_output) {
3593 rw="w";
3594 } else {
3595 rw="r";
3596 }
3597 f=fopen(fn,rw);
3598 if(f==0) {
3599 return 0;
3600 }
3601 pt=port_rep_from_file(sc,f,prop);
3602 pt->rep.stdio.closeit=1;
3603 pt->rep.stdio.interactive=0;
3604
3605 #if SHOW_ERROR_LINE
3606 if(fn)
3607 pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
3608
3609 pt->rep.stdio.curr_line = 0;
3610 #endif
3611 return pt;
3612 }
3613
3614 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
3615 port *pt;
3616 pt=port_rep_from_filename(sc,fn,prop);
3617 if(pt==0) {
3618 return sc->NIL;
3619 }
3620 return mk_port(sc,pt);
3621 }
3622
3623 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
3624 {
3625 port *pt;
3626
3627 pt = (port *)sc->malloc(sizeof *pt);
3628 if (pt == NULL) {
3629 return NULL;
3630 }
3631 pt->kind = port_file | prop;
3632 pt->rep.stdio.file = f;
3633 pt->rep.stdio.closeit = 0;
3634 pt->rep.stdio.interactive=sc->interactive_repl;
3635 return pt;
3636 }
3637
3638 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
3639 port *pt;
3640 pt=port_rep_from_file(sc,f,prop);
3641 if(pt==0) {
3642 return sc->NIL;
3643 }
3644 return mk_port(sc,pt);
3645 }
3646
3647 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
3648 port *pt;
3649 pt=(port*)sc->malloc(sizeof(port));
3650 if(pt==0) {
3651 return 0;
3652 }
3653 pt->kind=port_string|prop;
3654 pt->rep.string.start=start;
3655 pt->rep.string.curr=start;
3656 pt->rep.string.past_the_end=past_the_end;
3657 return pt;
3658 }
3659
3660 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
3661 port *pt;
3662 pt=port_rep_from_string(sc,start,past_the_end,prop);
3663 if(pt==0) {
3664 return sc->NIL;
3665 }
3666 return mk_port(sc,pt);
3667 }
3668
3669 #define BLOCK_SIZE 256
3670
3671 static port *port_rep_from_scratch(scheme *sc) {
3672 port *pt;
3673 char *start;
3674 pt=(port*)sc->malloc(sizeof(port));
3675 if(pt==0) {
3676 return 0;
3677 }
3678 start=sc->malloc(BLOCK_SIZE);
3679 if(start==0) {
3680 return 0;
3681 }
3682 memset(start,' ',BLOCK_SIZE-1);
3683 start[BLOCK_SIZE-1]='\0';
3684 pt->kind=port_string|port_output|port_srfi6;
3685 pt->rep.string.start=start;
3686 pt->rep.string.curr=start;
3687 pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
3688 return pt;
3689 }
3690
3691 static pointer port_from_scratch(scheme *sc) {
3692 port *pt;
3693 pt=port_rep_from_scratch(sc);
3694 if(pt==0) {
3695 return sc->NIL;
3696 }
3697 return mk_port(sc,pt);
3698 }
3699
3700 static void port_close(scheme *sc, pointer p, int flag) {
3701 port *pt=p->_object._port;
3702 pt->kind&=~flag;
3703 if((pt->kind & (port_input|port_output))==0) {
3704 if(pt->kind&port_file) {
3705
3706 #if SHOW_ERROR_LINE
3707 /* Cleanup is here so (close-*-port) functions could work too */
3708 pt->rep.stdio.curr_line = 0;
3709
3710 if(pt->rep.stdio.filename)
3711 sc->free(pt->rep.stdio.filename);
3712 #endif
3713
3714 fclose(pt->rep.stdio.file);
3715 }
3716 pt->kind=port_free;
3717 }
3718 }
3719
3720 /* get new character from input file */
3721 static int inchar(scheme *sc) {
3722 int c;
3723 port *pt;
3724
3725 pt = sc->inport->_object._port;
3726 if(pt->kind & port_saw_EOF)
3727 { return EOF; }
3728 c = basic_inchar(pt);
3729 if(c == EOF && sc->inport == sc->loadport) {
3730 /* Instead, set port_saw_EOF */
3731 pt->kind |= port_saw_EOF;
3732
3733 /* file_pop(sc); */
3734 return EOF;
3735 /* NOTREACHED */
3736 }
3737 return c;
3738 }
3739
3740 static int basic_inchar(port *pt) {
3741 if(pt->kind & port_file) {
3742 return fgetc(pt->rep.stdio.file);
3743 } else {
3744 if(*pt->rep.string.curr == 0 ||
3745 pt->rep.string.curr == pt->rep.string.past_the_end) {
3746 return EOF;
3747 } else {
3748 return *pt->rep.string.curr++;
3749 }
3750 }
3751 }
3752
3753 /* back character to input buffer */
3754 static void backchar(scheme *sc, int c) {
3755 port *pt;
3756 if(c==EOF) return;
3757 pt=sc->inport->_object._port;
3758 if(pt->kind&port_file) {
3759 ungetc(c,pt->rep.stdio.file);
3760 } else {
3761 if(pt->rep.string.curr!=pt->rep.string.start) {
3762 --pt->rep.string.curr;
3763 }
3764 }
3765 }
3766
3767 static int realloc_port_string(scheme *sc, port *p)
3768 {
3769 char *start=p->rep.string.start;
3770 size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
3771 char *str=sc->malloc(new_size);
3772 if(str) {
3773 memset(str,' ',new_size-1);
3774 str[new_size-1]='\0';
3775 strcpy(str,start);
3776 p->rep.string.start=str;
3777 p->rep.string.past_the_end=str+new_size-1;
3778 p->rep.string.curr-=start-str;
3779 sc->free(start);
3780 return 1;
3781 } else {
3782 return 0;
3783 }
3784 }
3785
3786 INTERFACE void putstr(scheme *sc, const char *s) {
3787 port *pt=sc->outport->_object._port;
3788 if(pt->kind&port_file) {
3789 fputs(s,pt->rep.stdio.file);
3790 if( pt->rep.stdio.interactive )
3791 fflush( pt->rep.stdio.file );
3792 } else {
3793 for(;*s;s++) {
3794 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
3795 *pt->rep.string.curr++=*s;
3796 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
3797 *pt->rep.string.curr++=*s;
3798 }
3799 }
3800 }
3801 }
3802
3803 static void putchars(scheme *sc, const char *s, int len) {
3804 port *pt=sc->outport->_object._port;
3805 if(pt->kind&port_file) {
3806 fwrite(s,1,len,pt->rep.stdio.file);
3807 } else {
3808 for(;len;len--) {
3809 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
3810 *pt->rep.string.curr++=*s++;
3811 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
3812 *pt->rep.string.curr++=*s++;
3813 }
3814 }
3815 }
3816 }
3817
3818 INTERFACE void putcharacter(scheme *sc, int c) {
3819 port *pt=sc->outport->_object._port;
3820 if(pt->kind&port_file) {
3821 fputc(c,pt->rep.stdio.file);
3822 } else {
3823 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
3824 *pt->rep.string.curr++=c;
3825 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
3826 *pt->rep.string.curr++=c;
3827 }
3828 }
3829 }
3830
3831 /* read characters up to delimiter, but cater to character constants */
3832 static char *readstr_upto(scheme *sc, char *delim) {
3833 char *p = sc->strbuff;
3834
3835 while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
3836 !is_one_of(delim, (*p++ = inchar(sc))));
3837
3838 if(p == sc->strbuff+2 && p[-2] == '\\') {
3839 *p=0;
3840 } else {
3841 backchar(sc,p[-1]);
3842 *--p = '\0';
3843 }
3844 return sc->strbuff;
3845 }
3846
3847 /* read string expression "xxx...xxx" */
3848 static pointer readstrexp(scheme *sc) {
3849 char *p = sc->strbuff;
3850 int c;
3851 int c1=0;
3852 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
3853
3854 for (;;) {
3855 c=inchar(sc);
3856 if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
3857 return sc->F;
3858 }
3859 switch(state) {
3860 case st_ok:
3861 switch(c) {
3862 case '\\':
3863 state=st_bsl;
3864 break;
3865 case '"':
3866 *p=0;
3867 return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
3868 default:
3869 *p++=c;
3870 break;
3871 }
3872 break;
3873 case st_bsl:
3874 switch(c) {
3875 case '0':
3876 case '1':
3877 case '2':
3878 case '3':
3879 case '4':
3880 case '5':
3881 case '6':
3882 case '7':
3883 state=st_oct1;
3884 c1=c-'0';
3885 break;
3886 case 'x':
3887 case 'X':
3888 state=st_x1;
3889 c1=0;
3890 break;
3891 case 'n':
3892 *p++='\n';
3893 state=st_ok;
3894 break;
3895 case 't':
3896 *p++='\t';
3897 state=st_ok;
3898 break;
3899 case 'r':
3900 *p++='\r';
3901 state=st_ok;
3902 break;
3903 case '"':
3904 *p++='"';
3905 state=st_ok;
3906 break;
3907 default:
3908 *p++=c;
3909 state=st_ok;
3910 break;
3911 }
3912 break;
3913 case st_x1:
3914 case st_x2:
3915 c=toupper(c);
3916 if(c>='0' && c<='F') {
3917 if(c<='9') {
3918 c1=(c1<<4)+c-'0';
3919 } else {
3920 c1=(c1<<4)+c-'A'+10;
3921 }
3922 if(state==st_x1) {
3923 state=st_x2;
3924 } else {
3925 *p++=c1;
3926 state=st_ok;
3927 }
3928 } else {
3929 return sc->F;
3930 }
3931 break;
3932 case st_oct1:
3933 case st_oct2:
3934 if (c < '0' || c > '7')
3935 {
3936 *p++=c1;
3937 backchar(sc, c);
3938 state=st_ok;
3939 }
3940 else
3941 {
3942 if (state==st_oct2 && c1 >= 32)
3943 return sc->F;
3944
3945 c1=(c1<<3)+(c-'0');
3946
3947 if (state == st_oct1)
3948 state=st_oct2;
3949 else
3950 {
3951 *p++=c1;
3952 state=st_ok;
3953 }
3954 }
3955 break;
3956
3957 }
3958 }
3959 }
3960
3961 /* check c is in chars */
3962 static INLINE int is_one_of(char *s, int c) {
3963 if(c==EOF) return 1;
3964 while (*s)
3965 if (*s++ == c)
3966 return (1);
3967 return (0);
3968 }
3969
3970 /* skip white characters */
3971 static INLINE int skipspace(scheme *sc) {
3972 int c = 0, curr_line = 0;
3973
3974 do {
3975 c=inchar(sc);
3976 #if SHOW_ERROR_LINE
3977 if(c=='\n')
3978 curr_line++;
3979 #endif
3980 } while (isspace(c));
3981
3982 /* record it */
3983 #if SHOW_ERROR_LINE
3984 if (sc->load_stack[sc->file_i].kind & port_file)
3985 sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
3986 #endif
3987
3988 if(c!=EOF) {
3989 backchar(sc,c);
3990 return 1;
3991 }
3992 else
3993 { return EOF; }
3994 }
3995
3996 /* get token */
3997 static int token(scheme *sc) {
3998 int c;
3999 c = skipspace(sc);
4000 if(c == EOF) { return (TOK_EOF); }
4001 switch (c=inchar(sc)) {
4002 case EOF:
4003 return (TOK_EOF);
4004 case '(':
4005 return (TOK_LPAREN);
4006 case ')':
4007 return (TOK_RPAREN);
4008 case '.':
4009 c=inchar(sc);
4010 if(is_one_of(" \n\t",c)) {
4011 return (TOK_DOT);
4012 } else {
4013 backchar(sc,c);
4014 backchar(sc,'.');
4015 return TOK_ATOM;
4016 }
4017 case '\'':
4018 return (TOK_QUOTE);
4019 case ';':
4020 while ((c=inchar(sc)) != '\n' && c!=EOF)
4021 ;
4022
4023 #if SHOW_ERROR_LINE
4024 if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
4025 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
4026 #endif
4027
4028 if(c == EOF)
4029 { return (TOK_EOF); }
4030 else
4031 { return (token(sc));}
4032 case '"':
4033 return (TOK_DQUOTE);
4034 case BACKQUOTE:
4035 return (TOK_BQUOTE);
4036 case ',':
4037 if ((c=inchar(sc)) == '@') {
4038 return (TOK_ATMARK);
4039 } else {
4040 backchar(sc,c);
4041 return (TOK_COMMA);
4042 }
4043 case '#':
4044 c=inchar(sc);
4045 if (c == '(') {
4046 return (TOK_VEC);
4047 } else if(c == '!') {
4048 while ((c=inchar(sc)) != '\n' && c!=EOF)
4049 ;
4050
4051 #if SHOW_ERROR_LINE
4052 if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
4053 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
4054 #endif
4055
4056 if(c == EOF)
4057 { return (TOK_EOF); }
4058 else
4059 { return (token(sc));}
4060 } else {
4061 backchar(sc,c);
4062 if(is_one_of(" tfodxb\\",c)) {
4063 return TOK_SHARP_CONST;
4064 } else {
4065 return (TOK_SHARP);
4066 }
4067 }
4068 default:
4069 backchar(sc,c);
4070 return (TOK_ATOM);
4071 }
4072 }
4073
4074 /* ========== Routines for Printing ========== */
4075 #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
4076
4077 static void printslashstring(scheme *sc, char *p, int len) {
4078 int i;
4079 unsigned char *s=(unsigned char*)p;
4080 putcharacter(sc,'"');
4081 for ( i=0; i<len; i++) {
4082 if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
4083 putcharacter(sc,'\\');
4084 switch(*s) {
4085 case '"':
4086 putcharacter(sc,'"');
4087 break;
4088 case '\n':
4089 putcharacter(sc,'n');
4090 break;
4091 case '\t':
4092 putcharacter(sc,'t');
4093 break;
4094 case '\r':
4095 putcharacter(sc,'r');
4096 break;
4097 case '\\':
4098 putcharacter(sc,'\\');
4099 break;
4100 default: {
4101 int d=*s/16;
4102 putcharacter(sc,'x');
4103 if(d<10) {
4104 putcharacter(sc,d+'0');
4105 } else {
4106 putcharacter(sc,d-10+'A');
4107 }
4108 d=*s%16;
4109 if(d<10) {
4110 putcharacter(sc,d+'0');
4111 } else {
4112 putcharacter(sc,d-10+'A');
4113 }
4114 }
4115 }
4116 } else {
4117 putcharacter(sc,*s);
4118 }
4119 s++;
4120 }
4121 putcharacter(sc,'"');
4122 }
4123
4124
4125 /* print atoms */
4126 static void printatom(scheme *sc, pointer l, int f) {
4127 char *p;
4128 int len;
4129 atom2str(sc,l,f,&p,&len);
4130 putchars(sc,p,len);
4131 }
4132
4133
4134 /* Uses internal buffer unless string pointer is already available */
4135 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
4136 char *p;
4137
4138 if (l == sc->NIL) {
4139 p = "()";
4140 } else if (l == sc->T) {
4141 p = "#t";
4142 } else if (l == sc->F) {
4143 p = "#f";
4144 } else if (l == sc->EOF_OBJ) {
4145 p = "#<EOF>";
4146 } else if (is_port(l)) {
4147 p = sc->strbuff;
4148 snprintf(p, STRBUFFSIZE, "#<PORT>");
4149 } else if (is_number(l)) {
4150 p = sc->strbuff;
4151 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
4152 if(num_is_integer(l)) {
4153 snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
4154 } else {
4155 snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
4156 /* r5rs says there must be a '.' (unless 'e'?) */
4157 f = strcspn(p, ".e");
4158 if (p[f] == 0) {
4159 p[f] = '.'; /* not found, so add '.0' at the end */
4160 p[f+1] = '0';
4161 p[f+2] = 0;
4162 }
4163 }
4164 } else {
4165 long v = ivalue(l);
4166 if (f == 16) {
4167 if (v >= 0)
4168 snprintf(p, STRBUFFSIZE, "%lx", v);
4169 else
4170 snprintf(p, STRBUFFSIZE, "-%lx", -v);
4171 } else if (f == 8) {
4172 if (v >= 0)
4173 snprintf(p, STRBUFFSIZE, "%lo", v);
4174 else
4175 snprintf(p, STRBUFFSIZE, "-%lo", -v);
4176 } else if (f == 2) {
4177 unsigned long b = (v < 0) ? -v : v;
4178 p = &p[STRBUFFSIZE-1];
4179 *p = 0;
4180 do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
4181 if (v < 0) *--p = '-';
4182 }
4183 }
4184 } else if (is_string(l)) {
4185 if (!f) {
4186 p = strvalue(l);
4187 } else { /* Hack, uses the fact that printing is needed */
4188 *pp=sc->strbuff;
4189 *plen=0;
4190 printslashstring(sc, strvalue(l), strlength(l));
4191 return;
4192 }
4193 } else if (is_character(l)) {
4194 int c=charvalue(l);
4195 p = sc->strbuff;
4196 if (!f) {
4197 p[0]=c;
4198 p[1]=0;
4199 } else {
4200 switch(c) {
4201 case ' ':
4202 snprintf(p,STRBUFFSIZE,"#\\space"); break;
4203 case '\n':
4204 snprintf(p,STRBUFFSIZE,"#\\newline"); break;
4205 case '\r':
4206 snprintf(p,STRBUFFSIZE,"#\\return"); break;
4207 case '\t':
4208 snprintf(p,STRBUFFSIZE,"#\\tab"); break;
4209 default:
4210 #if USE_ASCII_NAMES
4211 if(c==127) {
4212 snprintf(p,STRBUFFSIZE, "#\\del");
4213 break;
4214 } else if(c<32) {
4215 snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]);
4216 break;
4217 }
4218 #else
4219 if(c<32) {
4220 snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
4221 break;
4222 }
4223 #endif
4224 snprintf(p,STRBUFFSIZE,"#\\%c",c); break;
4225 break;
4226 }
4227 }
4228 } else if (is_symbol(l)) {
4229 p = symname(l);
4230 } else if (is_proc(l)) {
4231 p = sc->strbuff;
4232 snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
4233 } else if (is_macro(l)) {
4234 p = "#<MACRO>";
4235 } else if (is_closure(l)) {
4236 p = "#<CLOSURE>";
4237 } else if (is_promise(l)) {
4238 p = "#<PROMISE>";
4239 } else if (is_foreign(l)) {
4240 p = sc->strbuff;
4241 snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
4242 } else if (is_continuation(l)) {
4243 p = "#<CONTINUATION>";
4244 } else {
4245 p = "#<ERROR>";
4246 }
4247 *pp=p;
4248 *plen=strlen(p);
4249 }
4250 /* ========== Routines for Evaluation Cycle ========== */
4251
4252 /* make closure. c is code. e is environment */
4253 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
4254 pointer x = get_cell(sc, c, e);
4255
4256 typeflag(x) = T_CLOSURE;
4257 car(x) = c;
4258 cdr(x) = e;
4259 return (x);
4260 }
4261
4262 /* make continuation. */
4263 static pointer mk_continuation(scheme *sc, pointer d) {
4264 pointer x = get_cell(sc, sc->NIL, d);
4265
4266 typeflag(x) = T_CONTINUATION;
4267 cont_dump(x) = d;
4268 return (x);
4269 }
4270
4271 static pointer list_star(scheme *sc, pointer d) {
4272 pointer p, q;
4273 if(cdr(d)==sc->NIL) {
4274 return car(d);
4275 }
4276 p=cons(sc,car(d),cdr(d));
4277 q=p;
4278 while(cdr(cdr(p))!=sc->NIL) {
4279 d=cons(sc,car(p),cdr(p));
4280 if(cdr(cdr(p))!=sc->NIL) {
4281 p=cdr(d);
4282 }
4283 }
4284 cdr(p)=car(cdr(p));
4285 return q;
4286 }
4287
4288 /* reverse list -- produce new list */
4289 static pointer reverse(scheme *sc, pointer a) {
4290 /* a must be checked by gc */
4291 pointer p = sc->NIL;
4292
4293 for ( ; is_pair(a); a = cdr(a)) {
4294 p = cons(sc, car(a), p);
4295 }
4296 return (p);
4297 }
4298
4299 /* reverse list --- in-place */
4300 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
4301 pointer p = list, result = term, q;
4302
4303 while (p != sc->NIL) {
4304 q = cdr(p);
4305 cdr(p) = result;
4306 result = p;
4307 p = q;
4308 }
4309 return (result);
4310 }
4311
4312 /* append list -- produce new list (in reverse order) */
4313 static pointer revappend(scheme *sc, pointer a, pointer b) {
4314 pointer result = a;
4315 pointer p = b;
4316
4317 while (is_pair(p)) {
4318 result = cons(sc, car(p), result);
4319 p = cdr(p);
4320 }
4321
4322 if (p == sc->NIL) {
4323 return result;
4324 }
4325
4326 return sc->F; /* signal an error */
4327 }
4328
4329 /* equivalence of atoms */
4330 int eqv(pointer a, pointer b) {
4331 if (is_string(a)) {
4332 if (is_string(b))
4333 return (strvalue(a) == strvalue(b));
4334 else
4335 return (0);
4336 } else if (is_number(a)) {
4337 if (is_number(b)) {
4338 if (num_is_integer(a) == num_is_integer(b))
4339 return num_eq(nvalue(a),nvalue(b));
4340 }
4341 return (0);
4342 } else if (is_character(a)) {
4343 if (is_character(b))
4344 return charvalue(a)==charvalue(b);
4345 else
4346 return (0);
4347 } else if (is_port(a)) {
4348 if (is_port(b))
4349 return a==b;
4350 else
4351 return (0);
4352 } else if (is_proc(a)) {
4353 if (is_proc(b))
4354 return procnum(a)==procnum(b);
4355 else
4356 return (0);
4357 } else {
4358 return (a == b);
4359 }
4360 }
4361
4362 /* true or false value macro */
4363 /* () is #t in R5RS */
4364 #define is_true(p) ((p) != sc->F)
4365 #define is_false(p) ((p) == sc->F)
4366
4367 /* ========== Environment implementation ========== */
4368
4369 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
4370
4371 static int hash_fn(const char *key, int table_size)
4372 {
4373 unsigned int hashed = 0;
4374 const char *c;
4375 int bits_per_int = sizeof(unsigned int)*8;
4376
4377 for (c = key; *c; c++) {
4378 /* letters have about 5 bits in them */
4379 hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
4380 hashed ^= *c;
4381 }
4382 return hashed % table_size;
4383 }
4384 #endif
4385
4386 #ifndef USE_ALIST_ENV
4387
4388 /*
4389 * In this implementation, each frame of the environment may be
4390 * a hash table: a vector of alists hashed by variable name.
4391 * In practice, we use a vector only for the initial frame;
4392 * subsequent frames are too small and transient for the lookup
4393 * speed to out-weigh the cost of making a new vector.
4394 */
4395
4396 static void new_frame_in_env(scheme *sc, pointer old_env)
4397 {
4398 pointer new_frame;
4399
4400 /* The interaction-environment has about 300 variables in it. */
4401 if (old_env == sc->NIL) {
4402 new_frame = mk_vector(sc, 461);
4403 } else {
4404 new_frame = sc->NIL;
4405 }
4406
4407 sc->envir = immutable_cons(sc, new_frame, old_env);
4408 setenvironment(sc->envir);
4409 }
4410
4411 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
4412 pointer variable, pointer value)
4413 {
4414 pointer slot = immutable_cons(sc, variable, value);
4415
4416 if (is_vector(car(env))) {
4417 int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
4418
4419 set_vector_elem(car(env), location,
4420 immutable_cons(sc, slot, vector_elem(car(env), location)));
4421 } else {
4422 car(env) = immutable_cons(sc, slot, car(env));
4423 }
4424 }
4425
4426 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
4427 {
4428 pointer x,y;
4429 int location;
4430
4431 for (x = env; x != sc->NIL; x = cdr(x)) {
4432 if (is_vector(car(x))) {
4433 location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
4434 y = vector_elem(car(x), location);
4435 } else {
4436 y = car(x);
4437 }
4438 for ( ; y != sc->NIL; y = cdr(y)) {
4439 if (caar(y) == hdl) {
4440 break;
4441 }
4442 }
4443 if (y != sc->NIL) {
4444 break;
4445 }
4446 if(!all) {
4447 return sc->NIL;
4448 }
4449 }
4450 if (x != sc->NIL) {
4451 return car(y);
4452 }
4453 return sc->NIL;
4454 }
4455
4456 #else /* USE_ALIST_ENV */
4457
4458 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
4459 {
4460 sc->envir = immutable_cons(sc, sc->NIL, old_env);
4461 setenvironment(sc->envir);
4462 }
4463
4464 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
4465 pointer variable, pointer value)
4466 {
4467 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
4468 }
4469
4470 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
4471 {
4472 pointer x,y;
4473 for (x = env; x != sc->NIL; x = cdr(x)) {
4474 for (y = car(x); y != sc->NIL; y = cdr(y)) {
4475 if (caar(y) == hdl) {
4476 break;
4477 }
4478 }
4479 if (y != sc->NIL) {
4480 break;
4481 }
4482 if(!all) {
4483 return sc->NIL;
4484 }
4485 }
4486 if (x != sc->NIL) {
4487 return car(y);
4488 }
4489 return sc->NIL;
4490 }
4491
4492 #endif /* USE_ALIST_ENV else */
4493
4494 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
4495 {
4496 new_slot_spec_in_env(sc, sc->envir, variable, value);
4497 }
4498
4499 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
4500 {
4501 cdr(slot) = value;
4502 }
4503
4504 static INLINE pointer slot_value_in_env(pointer slot)
4505 {
4506 return cdr(slot);
4507 }
4508
4509 /* ========== Evaluation Cycle ========== */
4510
4511
4512 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
4513 const char *str = s;
4514 #if USE_ERROR_HOOK
4515 pointer x;
4516 pointer hdl=sc->ERROR_HOOK;
4517 #endif
4518
4519 #if SHOW_ERROR_LINE
4520 char sbuf[STRBUFFSIZE];
4521
4522 /* make sure error is not in REPL */
4523 if (sc->load_stack[sc->file_i].kind & port_file &&
4524 sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
4525 int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
4526 const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
4527
4528 /* should never happen */
4529 if(!fname) fname = "<unknown>";
4530
4531 /* we started from 0 */
4532 ln++;
4533 snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
4534
4535 str = (const char*)sbuf;
4536 }
4537 #endif
4538
4539 #if USE_ERROR_HOOK
4540 x=find_slot_in_env(sc,sc->envir,hdl,1);
4541 if (x != sc->NIL) {
4542 if(a!=0) {
4543 sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
4544 } else {
4545 sc->code = sc->NIL;
4546 }
4547 sc->code = cons(sc, mk_string(sc, str), sc->code);
4548 setimmutable(car(sc->code));
4549 sc->code = cons(sc, slot_value_in_env(x), sc->code);
4550 sc->op = (int)OP_EVAL;
4551 return sc->T;
4552 }
4553 #endif
4554
4555 if(a!=0) {
4556 sc->args = cons(sc, (a), sc->NIL);
4557 } else {
4558 sc->args = sc->NIL;
4559 }
4560 sc->args = cons(sc, mk_string(sc, str), sc->args);
4561 setimmutable(car(sc->args));
4562 sc->op = (int)OP_ERR0;
4563 return sc->T;
4564 }
4565 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
4566 #define Error_0(sc,s) return _Error_1(sc,s,0)
4567
4568 /* Too small to turn into function */
4569 # define BEGIN do {
4570 # define END } while (0)
4571 #define s_goto(sc,a) BEGIN \
4572 sc->op = (int)(a); \
4573 return sc->T; END
4574
4575 #define s_return(sc,a) return _s_return(sc,a)
4576
4577 #ifndef USE_SCHEME_STACK
4578
4579 /* this structure holds all the interpreter's registers */
4580 struct dump_stack_frame {
4581 enum scheme_opcodes op;
4582 pointer args;
4583 pointer envir;
4584 pointer code;
4585 };
4586
4587 #define STACK_GROWTH 3
4588
4589 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
4590 {
4591 int nframes = (int)sc->dump;
4592 struct dump_stack_frame *next_frame;
4593
4594 /* enough room for the next frame? */
4595 if (nframes >= sc->dump_size) {
4596 sc->dump_size += STACK_GROWTH;
4597 /* alas there is no sc->realloc */
4598 sc->dump_base = realloc(sc->dump_base,
4599 sizeof(struct dump_stack_frame) * sc->dump_size);
4600 }
4601 next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
4602 next_frame->op = op;
4603 next_frame->args = args;
4604 next_frame->envir = sc->envir;
4605 next_frame->code = code;
4606 sc->dump = (pointer)(nframes+1);
4607 }
4608
4609 static pointer _s_return(scheme *sc, pointer a)
4610 {
4611 int nframes = (int)sc->dump;
4612 struct dump_stack_frame *frame;
4613
4614 sc->value = (a);
4615 if (nframes <= 0) {
4616 return sc->NIL;
4617 }
4618 nframes--;
4619 frame = (struct dump_stack_frame *)sc->dump_base + nframes;
4620 sc->op = frame->op;
4621 sc->args = frame->args;
4622 sc->envir = frame->envir;
4623 sc->code = frame->code;
4624 sc->dump = (pointer)nframes;
4625 return sc->T;
4626 }
4627
4628 static INLINE void dump_stack_reset(scheme *sc)
4629 {
4630 /* in this implementation, sc->dump is the number of frames on the stack */
4631 sc->dump = (pointer)0;
4632 }
4633
4634 static INLINE void dump_stack_initialize(scheme *sc)
4635 {
4636 sc->dump_size = 0;
4637 sc->dump_base = NULL;
4638 dump_stack_reset(sc);
4639 }
4640
4641 static void dump_stack_free(scheme *sc)
4642 {
4643 free(sc->dump_base);
4644 sc->dump_base = NULL;
4645 sc->dump = (pointer)0;
4646 sc->dump_size = 0;
4647 }
4648
4649 static INLINE void dump_stack_mark(scheme *sc)
4650 {
4651 int nframes = (int)sc->dump;
4652 int i;
4653 for(i=0; i<nframes; i++) {
4654 struct dump_stack_frame *frame;
4655 frame = (struct dump_stack_frame *)sc->dump_base + i;
4656 mark(frame->args);
4657 mark(frame->envir);
4658 mark(frame->code);
4659 }
4660 }
4661
4662 #else
4663
4664 static INLINE void dump_stack_reset(scheme *sc)
4665 {
4666 sc->dump = sc->NIL;
4667 }
4668
4669 static INLINE void dump_stack_initialize(scheme *sc)
4670 {
4671 dump_stack_reset(sc);
4672 }
4673
4674 static void dump_stack_free(scheme *sc)
4675 {
4676 sc->dump = sc->NIL;
4677 }
4678
4679 static pointer _s_return(scheme *sc, pointer a) {
4680 sc->value = (a);
4681 if(sc->dump==sc->NIL) return sc->NIL;
4682 sc->op = ivalue(car(sc->dump));
4683 sc->args = cadr(sc->dump);
4684 sc->envir = caddr(sc->dump);
4685 sc->code = cadddr(sc->dump);
4686 sc->dump = cddddr(sc->dump);
4687 return sc->T;
4688 }
4689
4690 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
4691 sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
4692 sc->dump = cons(sc, (args), sc->dump);
4693 sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
4694 }
4695
4696 static INLINE void dump_stack_mark(scheme *sc)
4697 {
4698 mark(sc->dump);
4699 }
4700 #endif
4701
4702 #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
4703
4704 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
4705 pointer x, y;
4706
4707 switch (op) {
4708 case OP_LOAD: /* load */
4709 if(file_interactive(sc)) {
4710 fprintf(sc->outport->_object._port->rep.stdio.file,
4711 "Loading %s\n", strvalue(car(sc->args)));
4712 }
4713 if (!file_push(sc,strvalue(car(sc->args)))) {
4714 Error_1(sc,"unable to open", car(sc->args));
4715 }
4716 else
4717 {
4718 sc->args = mk_integer(sc,sc->file_i);
4719 s_goto(sc,OP_T0LVL);
4720 }
4721
4722 case OP_T0LVL: /* top level */
4723 /* If we reached the end of file, this loop is done. */
4724 if(sc->loadport->_object._port->kind & port_saw_EOF)
4725 {
4726 if(sc->file_i == 0)
4727 {
4728 sc->args=sc->NIL;
4729 s_goto(sc,OP_QUIT);
4730 }
4731 else
4732 {
4733 file_pop(sc);
4734 s_return(sc,sc->value);
4735 }
4736 /* NOTREACHED */
4737 }
4738
4739 /* If interactive, be nice to user. */
4740 if(file_interactive(sc))
4741 {
4742 sc->envir = sc->global_env;
4743 dump_stack_reset(sc);
4744 putstr(sc,"\n");
4745 putstr(sc,prompt);
4746 }
4747
4748 /* Set up another iteration of REPL */
4749 sc->nesting=0;
4750 sc->save_inport=sc->inport;
4751 sc->inport = sc->loadport;
4752 s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
4753 s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
4754 s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
4755 s_goto(sc,OP_READ_INTERNAL);
4756
4757 case OP_T1LVL: /* top level */
4758 sc->code = sc->value;
4759 sc->inport=sc->save_inport;
4760 s_goto(sc,OP_EVAL);
4761
4762 case OP_READ_INTERNAL: /* internal read */
4763 sc->tok = token(sc);
4764 if(sc->tok==TOK_EOF)
4765 { s_return(sc,sc->EOF_OBJ); }
4766 s_goto(sc,OP_RDSEXPR);
4767
4768 case OP_GENSYM:
4769 s_return(sc, gensym(sc));
4770
4771 case OP_VALUEPRINT: /* print evaluation result */
4772 /* OP_VALUEPRINT is always pushed, because when changing from
4773 non-interactive to interactive mode, it needs to be
4774 already on the stack */
4775 if(sc->tracing) {
4776 putstr(sc,"\nGives: ");
4777 }
4778 if(file_interactive(sc)) {
4779 sc->print_flag = 1;
4780 sc->args = sc->value;
4781 s_goto(sc,OP_P0LIST);
4782 } else {
4783 s_return(sc,sc->value);
4784 }
4785
4786 case OP_EVAL: /* main part of evaluation */
4787 #if USE_TRACING
4788 if(sc->tracing) {
4789 /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
4790 s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
4791 sc->args=sc->code;
4792 putstr(sc,"\nEval: ");
4793 s_goto(sc,OP_P0LIST);
4794 }
4795 /* fall through */
4796 case OP_REAL_EVAL:
4797 #endif
4798 if (is_symbol(sc->code)) { /* symbol */
4799 x=find_slot_in_env(sc,sc->envir,sc->code,1);
4800 if (x != sc->NIL) {
4801 s_return(sc,slot_value_in_env(x));
4802 } else {
4803 Error_1(sc,"eval: unbound variable:", sc->code);
4804 }
4805 } else if (is_pair(sc->code)) {
4806 if (is_syntax(x = car(sc->code))) { /* SYNTAX */
4807 sc->code = cdr(sc->code);
4808 s_goto(sc,syntaxnum(x));
4809 } else {/* first, eval top element and eval arguments */
4810 s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
4811 /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
4812 sc->code = car(sc->code);
4813 s_goto(sc,OP_EVAL);
4814 }
4815 } else {
4816 s_return(sc,sc->code);
4817 }
4818
4819 case OP_E0ARGS: /* eval arguments */
4820 if (is_macro(sc->value)) { /* macro expansion */
4821 s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
4822 sc->args = cons(sc,sc->code, sc->NIL);
4823 sc->code = sc->value;
4824 s_goto(sc,OP_APPLY);
4825 } else {
4826 sc->code = cdr(sc->code);
4827 s_goto(sc,OP_E1ARGS);
4828 }
4829
4830 case OP_E1ARGS: /* eval arguments */
4831 sc->args = cons(sc, sc->value, sc->args);
4832 if (is_pair(sc->code)) { /* continue */
4833 s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
4834 sc->code = car(sc->code);
4835 sc->args = sc->NIL;
4836 s_goto(sc,OP_EVAL);
4837 } else { /* end */
4838 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
4839 sc->code = car(sc->args);
4840 sc->args = cdr(sc->args);
4841 s_goto(sc,OP_APPLY);
4842 }
4843
4844 #if USE_TRACING
4845 case OP_TRACING: {
4846 int tr=sc->tracing;
4847 sc->tracing=ivalue(car(sc->args));
4848 s_return(sc,mk_integer(sc,tr));
4849 }
4850 #endif
4851
4852 case OP_APPLY: /* apply 'code' to 'args' */
4853 #if USE_TRACING
4854 if(sc->tracing) {
4855 s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
4856 sc->print_flag = 1;
4857 /* sc->args=cons(sc,sc->code,sc->args);*/
4858 putstr(sc,"\nApply to: ");
4859 s_goto(sc,OP_P0LIST);
4860 }
4861 /* fall through */
4862 case OP_REAL_APPLY:
4863 #endif
4864 if (is_proc(sc->code)) {
4865 s_goto(sc,procnum(sc->code)); /* PROCEDURE */
4866 } else if (is_foreign(sc->code))
4867 {
4868 /* Keep nested calls from GC'ing the arglist */
4869 push_recent_alloc(sc,sc->args,sc->NIL);
4870 x=sc->code->_object._ff(sc,sc->args);
4871 s_return(sc,x);
4872 } else if (is_closure(sc->code) || is_macro(sc->code)
4873 || is_promise(sc->code)) { /* CLOSURE */
4874 /* Should not accept promise */
4875 /* make environment */
4876 new_frame_in_env(sc, closure_env(sc->code));
4877 for (x = car(closure_code(sc->code)), y = sc->args;
4878 is_pair(x); x = cdr(x), y = cdr(y)) {
4879 if (y == sc->NIL) {
4880 Error_0(sc,"not enough arguments");
4881 } else {
4882 new_slot_in_env(sc, car(x), car(y));
4883 }
4884 }
4885 if (x == sc->NIL) {
4886 /*--
4887 * if (y != sc->NIL) {
4888 * Error_0(sc,"too many arguments");
4889 * }
4890 */
4891 } else if (is_symbol(x))
4892 new_slot_in_env(sc, x, y);
4893 else {
4894 Error_1(sc,"syntax error in closure: not a symbol:", x);
4895 }
4896 sc->code = cdr(closure_code(sc->code));
4897 sc->args = sc->NIL;
4898 s_goto(sc,OP_BEGIN);
4899 } else if (is_continuation(sc->code)) { /* CONTINUATION */
4900 sc->dump = cont_dump(sc->code);
4901 s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
4902 } else {
4903 Error_0(sc,"illegal function");
4904 }
4905
4906 case OP_DOMACRO: /* do macro */
4907 sc->code = sc->value;
4908 s_goto(sc,OP_EVAL);
4909
4910 #if 1
4911 case OP_LAMBDA: /* lambda */
4912 /* If the hook is defined, apply it to sc->code, otherwise
4913 set sc->value fall thru */
4914 {
4915 pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
4916 if(f==sc->NIL) {
4917 sc->value = sc->code;
4918 /* Fallthru */
4919 } else {
4920 s_save(sc,OP_LAMBDA1,sc->args,sc->code);
4921 sc->args=cons(sc,sc->code,sc->NIL);
4922 sc->code=slot_value_in_env(f);
4923 s_goto(sc,OP_APPLY);
4924 }
4925 }
4926
4927 case OP_LAMBDA1:
4928 s_return(sc,mk_closure(sc, sc->value, sc->envir));
4929
4930 #else
4931 case OP_LAMBDA: /* lambda */
4932 s_return(sc,mk_closure(sc, sc->code, sc->envir));
4933
4934 #endif
4935
4936 case OP_MKCLOSURE: /* make-closure */
4937 x=car(sc->args);
4938 if(car(x)==sc->LAMBDA) {
4939 x=cdr(x);
4940 }
4941 if(cdr(sc->args)==sc->NIL) {
4942 y=sc->envir;
4943 } else {
4944 y=cadr(sc->args);
4945 }
4946 s_return(sc,mk_closure(sc, x, y));
4947
4948 case OP_QUOTE: /* quote */
4949 s_return(sc,car(sc->code));
4950
4951 case OP_DEF0: /* define */
4952 if(is_immutable(car(sc->code)))
4953 Error_1(sc,"define: unable to alter immutable", car(sc->code));
4954
4955 if (is_pair(car(sc->code))) {
4956 x = caar(sc->code);
4957 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
4958 } else {
4959 x = car(sc->code);
4960 sc->code = cadr(sc->code);
4961 }
4962 if (!is_symbol(x)) {
4963 Error_0(sc,"variable is not a symbol");
4964 }
4965 s_save(sc,OP_DEF1, sc->NIL, x);
4966 s_goto(sc,OP_EVAL);
4967
4968 case OP_DEF1: /* define */
4969 x=find_slot_in_env(sc,sc->envir,sc->code,0);
4970 if (x != sc->NIL) {
4971 set_slot_in_env(sc, x, sc->value);
4972 } else {
4973 new_slot_in_env(sc, sc->code, sc->value);
4974 }
4975 s_return(sc,sc->code);
4976
4977
4978 case OP_DEFP: /* defined? */
4979 x=sc->envir;
4980 if(cdr(sc->args)!=sc->NIL) {
4981 x=cadr(sc->args);
4982 }
4983 s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
4984
4985 case OP_SET0: /* set! */
4986 if(is_immutable(car(sc->code)))
4987 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
4988 s_save(sc,OP_SET1, sc->NIL, car(sc->code));
4989 sc->code = cadr(sc->code);
4990 s_goto(sc,OP_EVAL);
4991
4992 case OP_SET1: /* set! */
4993 y=find_slot_in_env(sc,sc->envir,sc->code,1);
4994 if (y != sc->NIL) {
4995 set_slot_in_env(sc, y, sc->value);
4996 s_return(sc,sc->value);
4997 } else {
4998 Error_1(sc,"set!: unbound variable:", sc->code);
4999 }
5000
5001
5002 case OP_BEGIN: /* begin */
5003 if (!is_pair(sc->code)) {
5004 s_return(sc,sc->code);
5005 }
5006 if (cdr(sc->code) != sc->NIL) {
5007 s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
5008 }
5009 sc->code = car(sc->code);
5010 s_goto(sc,OP_EVAL);
5011
5012 case OP_IF0: /* if */
5013 s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
5014 sc->code = car(sc->code);
5015 s_goto(sc,OP_EVAL);
5016
5017 case OP_IF1: /* if */
5018 if (is_true(sc->value))
5019 sc->code = car(sc->code);
5020 else
5021 sc->code = cadr(sc->code); /* (if #f 1) ==> () because
5022 * car(sc->NIL) = sc->NIL */
5023 s_goto(sc,OP_EVAL);
5024
5025 case OP_LET0: /* let */
5026 sc->args = sc->NIL;
5027 sc->value = sc->code;
5028 sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
5029 s_goto(sc,OP_LET1);
5030
5031 case OP_LET1: /* let (calculate parameters) */
5032 sc->args = cons(sc, sc->value, sc->args);
5033 if (is_pair(sc->code)) { /* continue */
5034 if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
5035 Error_1(sc, "Bad syntax of binding spec in let :",
5036 car(sc->code));
5037 }
5038 s_save(sc,OP_LET1, sc->args, cdr(sc->code));
5039 sc->code = cadar(sc->code);
5040 sc->args = sc->NIL;
5041 s_goto(sc,OP_EVAL);
5042 } else { /* end */
5043 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
5044 sc->code = car(sc->args);
5045 sc->args = cdr(sc->args);
5046 s_goto(sc,OP_LET2);
5047 }
5048
5049 case OP_LET2: /* let */
5050 new_frame_in_env(sc, sc->envir);
5051 for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
5052 y != sc->NIL; x = cdr(x), y = cdr(y)) {
5053 new_slot_in_env(sc, caar(x), car(y));
5054 }
5055 if (is_symbol(car(sc->code))) { /* named let */
5056 for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
5057 if (!is_pair(x))
5058 Error_1(sc, "Bad syntax of binding in let :", x);
5059 if (!is_list(sc, car(x)))
5060 Error_1(sc, "Bad syntax of binding in let :", car(x));
5061 sc->args = cons(sc, caar(x), sc->args);
5062 }
5063 x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
5064 new_slot_in_env(sc, car(sc->code), x);
5065 sc->code = cddr(sc->code);
5066 sc->args = sc->NIL;
5067 } else {
5068 sc->code = cdr(sc->code);
5069 sc->args = sc->NIL;
5070 }
5071 s_goto(sc,OP_BEGIN);
5072
5073 case OP_LET0AST: /* let* */
5074 if (car(sc->code) == sc->NIL) {
5075 new_frame_in_env(sc, sc->envir);
5076 sc->code = cdr(sc->code);
5077 s_goto(sc,OP_BEGIN);
5078 }
5079 if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
5080 Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
5081 }
5082 s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
5083 sc->code = cadaar(sc->code);
5084 s_goto(sc,OP_EVAL);
5085
5086 case OP_LET1AST: /* let* (make new frame) */
5087 new_frame_in_env(sc, sc->envir);
5088 s_goto(sc,OP_LET2AST);
5089
5090 case OP_LET2AST: /* let* (calculate parameters) */
5091 new_slot_in_env(sc, caar(sc->code), sc->value);
5092 sc->code = cdr(sc->code);
5093 if (is_pair(sc->code)) { /* continue */
5094 s_save(sc,OP_LET2AST, sc->args, sc->code);
5095 sc->code = cadar(sc->code);
5096 sc->args = sc->NIL;
5097 s_goto(sc,OP_EVAL);
5098 } else { /* end */
5099 sc->code = sc->args;
5100 sc->args = sc->NIL;
5101 s_goto(sc,OP_BEGIN);
5102 }
5103 default:
5104 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5105 Error_0(sc,sc->strbuff);
5106 }
5107 return sc->T;
5108 }
5109
5110 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
5111 pointer x, y;
5112
5113 switch (op) {
5114 case OP_LET0REC: /* letrec */
5115 new_frame_in_env(sc, sc->envir);
5116 sc->args = sc->NIL;
5117 sc->value = sc->code;
5118 sc->code = car(sc->code);
5119 s_goto(sc,OP_LET1REC);
5120
5121 case OP_LET1REC: /* letrec (calculate parameters) */
5122 sc->args = cons(sc, sc->value, sc->args);
5123 if (is_pair(sc->code)) { /* continue */
5124 if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
5125 Error_1(sc, "Bad syntax of binding spec in letrec :",
5126 car(sc->code));
5127 }
5128 s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
5129 sc->code = cadar(sc->code);
5130 sc->args = sc->NIL;
5131 s_goto(sc,OP_EVAL);
5132 } else { /* end */
5133 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
5134 sc->code = car(sc->args);
5135 sc->args = cdr(sc->args);
5136 s_goto(sc,OP_LET2REC);
5137 }
5138
5139 case OP_LET2REC: /* letrec */
5140 for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
5141 new_slot_in_env(sc, caar(x), car(y));
5142 }
5143 sc->code = cdr(sc->code);
5144 sc->args = sc->NIL;
5145 s_goto(sc,OP_BEGIN);
5146
5147 case OP_COND0: /* cond */
5148 if (!is_pair(sc->code)) {
5149 Error_0(sc,"syntax error in cond");
5150 }
5151 s_save(sc,OP_COND1, sc->NIL, sc->code);
5152 sc->code = caar(sc->code);
5153 s_goto(sc,OP_EVAL);
5154
5155 case OP_COND1: /* cond */
5156 if (is_true(sc->value)) {
5157 if ((sc->code = cdar(sc->code)) == sc->NIL) {
5158 s_return(sc,sc->value);
5159 }
5160 if(car(sc->code)==sc->FEED_TO) {
5161 if(!is_pair(cdr(sc->code))) {
5162 Error_0(sc,"syntax error in cond");
5163 }
5164 x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
5165 sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
5166 s_goto(sc,OP_EVAL);
5167 }
5168 s_goto(sc,OP_BEGIN);
5169 } else {
5170 if ((sc->code = cdr(sc->code)) == sc->NIL) {
5171 s_return(sc,sc->NIL);
5172 } else {
5173 s_save(sc,OP_COND1, sc->NIL, sc->code);
5174 sc->code = caar(sc->code);
5175 s_goto(sc,OP_EVAL);
5176 }
5177 }
5178
5179 case OP_DELAY: /* delay */
5180 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
5181 typeflag(x)=T_PROMISE;
5182 s_return(sc,x);
5183
5184 case OP_AND0: /* and */
5185 if (sc->code == sc->NIL) {
5186 s_return(sc,sc->T);
5187 }
5188 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
5189 sc->code = car(sc->code);
5190 s_goto(sc,OP_EVAL);
5191
5192 case OP_AND1: /* and */
5193 if (is_false(sc->value)) {
5194 s_return(sc,sc->value);
5195 } else if (sc->code == sc->NIL) {
5196 s_return(sc,sc->value);
5197 } else {
5198 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
5199 sc->code = car(sc->code);
5200 s_goto(sc,OP_EVAL);
5201 }
5202
5203 case OP_OR0: /* or */
5204 if (sc->code == sc->NIL) {
5205 s_return(sc,sc->F);
5206 }
5207 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
5208 sc->code = car(sc->code);
5209 s_goto(sc,OP_EVAL);
5210
5211 case OP_OR1: /* or */
5212 if (is_true(sc->value)) {
5213 s_return(sc,sc->value);
5214 } else if (sc->code == sc->NIL) {
5215 s_return(sc,sc->value);
5216 } else {
5217 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
5218 sc->code = car(sc->code);
5219 s_goto(sc,OP_EVAL);
5220 }
5221
5222 case OP_C0STREAM: /* cons-stream */
5223 s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
5224 sc->code = car(sc->code);
5225 s_goto(sc,OP_EVAL);
5226
5227 case OP_C1STREAM: /* cons-stream */
5228 sc->args = sc->value; /* save sc->value to register sc->args for gc */
5229 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
5230 typeflag(x)=T_PROMISE;
5231 s_return(sc,cons(sc, sc->args, x));
5232
5233 case OP_MACRO0: /* macro */
5234 if (is_pair(car(sc->code))) {
5235 x = caar(sc->code);
5236 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
5237 } else {
5238 x = car(sc->code);
5239 sc->code = cadr(sc->code);
5240 }
5241 if (!is_symbol(x)) {
5242 Error_0(sc,"variable is not a symbol");
5243 }
5244 s_save(sc,OP_MACRO1, sc->NIL, x);
5245 s_goto(sc,OP_EVAL);
5246
5247 case OP_MACRO1: /* macro */
5248 typeflag(sc->value) = T_MACRO;
5249 x = find_slot_in_env(sc, sc->envir, sc->code, 0);
5250 if (x != sc->NIL) {
5251 set_slot_in_env(sc, x, sc->value);
5252 } else {
5253 new_slot_in_env(sc, sc->code, sc->value);
5254 }
5255 s_return(sc,sc->code);
5256
5257 case OP_CASE0: /* case */
5258 s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
5259 sc->code = car(sc->code);
5260 s_goto(sc,OP_EVAL);
5261
5262 case OP_CASE1: /* case */
5263 for (x = sc->code; x != sc->NIL; x = cdr(x)) {
5264 if (!is_pair(y = caar(x))) {
5265 break;
5266 }
5267 for ( ; y != sc->NIL; y = cdr(y)) {
5268 if (eqv(car(y), sc->value)) {
5269 break;
5270 }
5271 }
5272 if (y != sc->NIL) {
5273 break;
5274 }
5275 }
5276 if (x != sc->NIL) {
5277 if (is_pair(caar(x))) {
5278 sc->code = cdar(x);
5279 s_goto(sc,OP_BEGIN);
5280 } else {/* else */
5281 s_save(sc,OP_CASE2, sc->NIL, cdar(x));
5282 sc->code = caar(x);
5283 s_goto(sc,OP_EVAL);
5284 }
5285 } else {
5286 s_return(sc,sc->NIL);
5287 }
5288
5289 case OP_CASE2: /* case */
5290 if (is_true(sc->value)) {
5291 s_goto(sc,OP_BEGIN);
5292 } else {
5293 s_return(sc,sc->NIL);
5294 }
5295
5296 case OP_PAPPLY: /* apply */
5297 sc->code = car(sc->args);
5298 sc->args = list_star(sc,cdr(sc->args));
5299 /*sc->args = cadr(sc->args);*/
5300 s_goto(sc,OP_APPLY);
5301
5302 case OP_PEVAL: /* eval */
5303 if(cdr(sc->args)!=sc->NIL) {
5304 sc->envir=cadr(sc->args);
5305 }
5306 sc->code = car(sc->args);
5307 s_goto(sc,OP_EVAL);
5308
5309 case OP_CONTINUATION: /* call-with-current-continuation */
5310 sc->code = car(sc->args);
5311 sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
5312 s_goto(sc,OP_APPLY);
5313
5314 default:
5315 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5316 Error_0(sc,sc->strbuff);
5317 }
5318 return sc->T;
5319 }
5320
5321 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
5322 pointer x;
5323 num v;
5324 #if USE_MATH
5325 double dd;
5326 #endif
5327
5328 switch (op) {
5329 #if USE_MATH
5330 case OP_INEX2EX: /* inexact->exact */
5331 x=car(sc->args);
5332 if(num_is_integer(x)) {
5333 s_return(sc,x);
5334 } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
5335 s_return(sc,mk_integer(sc,ivalue(x)));
5336 } else {
5337 Error_1(sc,"inexact->exact: not integral:",x);
5338 }
5339
5340 case OP_EXP:
5341 x=car(sc->args);
5342 s_return(sc, mk_real(sc, exp(rvalue(x))));
5343
5344 case OP_LOG:
5345 x=car(sc->args);
5346 s_return(sc, mk_real(sc, log(rvalue(x))));
5347
5348 case OP_SIN:
5349 x=car(sc->args);
5350 s_return(sc, mk_real(sc, sin(rvalue(x))));
5351
5352 case OP_COS:
5353 x=car(sc->args);
5354 s_return(sc, mk_real(sc, cos(rvalue(x))));
5355
5356 case OP_TAN:
5357 x=car(sc->args);
5358 s_return(sc, mk_real(sc, tan(rvalue(x))));
5359
5360 case OP_ASIN:
5361 x=car(sc->args);
5362 s_return(sc, mk_real(sc, asin(rvalue(x))));
5363
5364 case OP_ACOS:
5365 x=car(sc->args);
5366 s_return(sc, mk_real(sc, acos(rvalue(x))));
5367
5368 case OP_ATAN:
5369 x=car(sc->args);
5370 if(cdr(sc->args)==sc->NIL) {
5371 s_return(sc, mk_real(sc, atan(rvalue(x))));
5372 } else {
5373 pointer y=cadr(sc->args);
5374 s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
5375 }
5376
5377 case OP_SQRT:
5378 x=car(sc->args);
5379 s_return(sc, mk_real(sc, sqrt(rvalue(x))));
5380
5381 case OP_EXPT: {
5382 double result;
5383 int real_result=1;
5384 pointer y=cadr(sc->args);
5385 x=car(sc->args);
5386 if (num_is_integer(x) && num_is_integer(y))
5387 real_result=0;
5388 /* This 'if' is an R5RS compatibility fix. */
5389 /* NOTE: Remove this 'if' fix for R6RS. */
5390 if (rvalue(x) == 0 && rvalue(y) < 0) {
5391 result = 0.0;
5392 } else {
5393 result = pow(rvalue(x),rvalue(y));
5394 }
5395 /* Before returning integer result make sure we can. */
5396 /* If the test fails, result is too big for integer. */
5397 if (!real_result)
5398 {
5399 long result_as_long = (long)result;
5400 if (result != (double)result_as_long)
5401 real_result = 1;
5402 }
5403 if (real_result) {
5404 s_return(sc, mk_real(sc, result));
5405 } else {
5406 s_return(sc, mk_integer(sc, result));
5407 }
5408 }
5409
5410 case OP_FLOOR:
5411 x=car(sc->args);
5412 s_return(sc, mk_real(sc, floor(rvalue(x))));
5413
5414 case OP_CEILING:
5415 x=car(sc->args);
5416 s_return(sc, mk_real(sc, ceil(rvalue(x))));
5417
5418 case OP_TRUNCATE : {
5419 double rvalue_of_x ;
5420 x=car(sc->args);
5421 rvalue_of_x = rvalue(x) ;
5422 if (rvalue_of_x > 0) {
5423 s_return(sc, mk_real(sc, floor(rvalue_of_x)));
5424 } else {
5425 s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
5426 }
5427 }
5428
5429 case OP_ROUND:
5430 x=car(sc->args);
5431 if (num_is_integer(x))
5432 s_return(sc, x);
5433 s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
5434 #endif
5435
5436 case OP_ADD: /* + */
5437 v=num_zero;
5438 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
5439 v=num_add(v,nvalue(car(x)));
5440 }
5441 s_return(sc,mk_number(sc, v));
5442
5443 case OP_MUL: /* * */
5444 v=num_one;
5445 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
5446 v=num_mul(v,nvalue(car(x)));
5447 }
5448 s_return(sc,mk_number(sc, v));
5449
5450 case OP_SUB: /* - */
5451 if(cdr(sc->args)==sc->NIL) {
5452 x=sc->args;
5453 v=num_zero;
5454 } else {
5455 x = cdr(sc->args);
5456 v = nvalue(car(sc->args));
5457 }
5458 for (; x != sc->NIL; x = cdr(x)) {
5459 v=num_sub(v,nvalue(car(x)));
5460 }
5461 s_return(sc,mk_number(sc, v));
5462
5463 case OP_DIV: /* / */
5464 if(cdr(sc->args)==sc->NIL) {
5465 x=sc->args;
5466 v=num_one;
5467 } else {
5468 x = cdr(sc->args);
5469 v = nvalue(car(sc->args));
5470 }
5471 for (; x != sc->NIL; x = cdr(x)) {
5472 if (!is_zero_double(rvalue(car(x))))
5473 v=num_div(v,nvalue(car(x)));
5474 else {
5475 Error_0(sc,"/: division by zero");
5476 }
5477 }
5478 s_return(sc,mk_number(sc, v));
5479
5480 case OP_INTDIV: /* quotient */
5481 if(cdr(sc->args)==sc->NIL) {
5482 x=sc->args;
5483 v=num_one;
5484 } else {
5485 x = cdr(sc->args);
5486 v = nvalue(car(sc->args));
5487 }
5488 for (; x != sc->NIL; x = cdr(x)) {
5489 if (ivalue(car(x)) != 0)
5490 v=num_intdiv(v,nvalue(car(x)));
5491 else {
5492 Error_0(sc,"quotient: division by zero");
5493 }
5494 }
5495 s_return(sc,mk_number(sc, v));
5496
5497 case OP_REM: /* remainder */
5498 v = nvalue(car(sc->args));
5499 if (ivalue(cadr(sc->args)) != 0)
5500 v=num_rem(v,nvalue(cadr(sc->args)));
5501 else {
5502 Error_0(sc,"remainder: division by zero");
5503 }
5504 s_return(sc,mk_number(sc, v));
5505
5506 case OP_MOD: /* modulo */
5507 v = nvalue(car(sc->args));
5508 if (ivalue(cadr(sc->args)) != 0)
5509 v=num_mod(v,nvalue(cadr(sc->args)));
5510 else {
5511 Error_0(sc,"modulo: division by zero");
5512 }
5513 s_return(sc,mk_number(sc, v));
5514
5515 case OP_CAR: /* car */
5516 s_return(sc,caar(sc->args));
5517
5518 case OP_CDR: /* cdr */
5519 s_return(sc,cdar(sc->args));
5520
5521 case OP_CONS: /* cons */
5522 cdr(sc->args) = cadr(sc->args);
5523 s_return(sc,sc->args);
5524
5525 case OP_SETCAR: /* set-car! */
5526 if(!is_immutable(car(sc->args))) {
5527 caar(sc->args) = cadr(sc->args);
5528 s_return(sc,car(sc->args));
5529 } else {
5530 Error_0(sc,"set-car!: unable to alter immutable pair");
5531 }
5532
5533 case OP_SETCDR: /* set-cdr! */
5534 if(!is_immutable(car(sc->args))) {
5535 cdar(sc->args) = cadr(sc->args);
5536 s_return(sc,car(sc->args));
5537 } else {
5538 Error_0(sc,"set-cdr!: unable to alter immutable pair");
5539 }
5540
5541 case OP_CHAR2INT: { /* char->integer */
5542 char c;
5543 c=(char)ivalue(car(sc->args));
5544 s_return(sc,mk_integer(sc,(unsigned char)c));
5545 }
5546
5547 case OP_INT2CHAR: { /* integer->char */
5548 unsigned char c;
5549 c=(unsigned char)ivalue(car(sc->args));
5550 s_return(sc,mk_character(sc,(char)c));
5551 }
5552
5553 case OP_CHARUPCASE: {
5554 unsigned char c;
5555 c=(unsigned char)ivalue(car(sc->args));
5556 c=toupper(c);
5557 s_return(sc,mk_character(sc,(char)c));
5558 }
5559
5560 case OP_CHARDNCASE: {
5561 unsigned char c;
5562 c=(unsigned char)ivalue(car(sc->args));
5563 c=tolower(c);
5564 s_return(sc,mk_character(sc,(char)c));
5565 }
5566
5567 case OP_STR2SYM: /* string->symbol */
5568 s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
5569
5570 case OP_STR2ATOM: /* string->atom */ {
5571 char *s=strvalue(car(sc->args));
5572 long pf = 0;
5573 if(cdr(sc->args)!=sc->NIL) {
5574 /* we know cadr(sc->args) is a natural number */
5575 /* see if it is 2, 8, 10, or 16, or error */
5576 pf = ivalue_unchecked(cadr(sc->args));
5577 if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
5578 /* base is OK */
5579 }
5580 else {
5581 pf = -1;
5582 }
5583 }
5584 if (pf < 0) {
5585 Error_1(sc, "string->atom: bad base:", cadr(sc->args));
5586 } else if(*s=='#') /* no use of base! */ {
5587 s_return(sc, mk_sharp_const(sc, s+1));
5588 } else {
5589 if (pf == 0 || pf == 10) {
5590 s_return(sc, mk_atom(sc, s));
5591 }
5592 else {
5593 char *ep;
5594 long iv = strtol(s,&ep,(int )pf);
5595 if (*ep == 0) {
5596 s_return(sc, mk_integer(sc, iv));
5597 }
5598 else {
5599 s_return(sc, sc->F);
5600 }
5601 }
5602 }
5603 }
5604
5605 case OP_SYM2STR: /* symbol->string */
5606 x=mk_string(sc,symname(car(sc->args)));
5607 setimmutable(x);
5608 s_return(sc,x);
5609
5610 case OP_ATOM2STR: /* atom->string */ {
5611 long pf = 0;
5612 x=car(sc->args);
5613 if(cdr(sc->args)!=sc->NIL) {
5614 /* we know cadr(sc->args) is a natural number */
5615 /* see if it is 2, 8, 10, or 16, or error */
5616 pf = ivalue_unchecked(cadr(sc->args));
5617 if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
5618 /* base is OK */
5619 }
5620 else {
5621 pf = -1;
5622 }
5623 }
5624 if (pf < 0) {
5625 Error_1(sc, "atom->string: bad base:", cadr(sc->args));
5626 } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
5627 char *p;
5628 int len;
5629 atom2str(sc,x,(int )pf,&p,&len);
5630 s_return(sc,mk_counted_string(sc,p,len));
5631 } else {
5632 Error_1(sc, "atom->string: not an atom:", x);
5633 }
5634 }
5635
5636 case OP_MKSTRING: { /* make-string */
5637 int fill=' ';
5638 int len;
5639
5640 len=ivalue(car(sc->args));
5641
5642 if(cdr(sc->args)!=sc->NIL) {
5643 fill=charvalue(cadr(sc->args));
5644 }
5645 s_return(sc,mk_empty_string(sc,len,(char)fill));
5646 }
5647
5648 case OP_STRLEN: /* string-length */
5649 s_return(sc,mk_integer(sc,strlength(car(sc->args))));
5650
5651 case OP_STRREF: { /* string-ref */
5652 char *str;
5653 int index;
5654
5655 str=strvalue(car(sc->args));
5656
5657 index=ivalue(cadr(sc->args));
5658
5659 if(index>=strlength(car(sc->args))) {
5660 Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
5661 }
5662
5663 s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
5664 }
5665
5666 case OP_STRSET: { /* string-set! */
5667 char *str;
5668 int index;
5669 int c;
5670
5671 if(is_immutable(car(sc->args))) {
5672 Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
5673 }
5674 str=strvalue(car(sc->args));
5675
5676 index=ivalue(cadr(sc->args));
5677 if(index>=strlength(car(sc->args))) {
5678 Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
5679 }
5680
5681 c=charvalue(caddr(sc->args));
5682
5683 str[index]=(char)c;
5684 s_return(sc,car(sc->args));
5685 }
5686
5687 case OP_STRAPPEND: { /* string-append */
5688 /* in 1.29 string-append was in Scheme in init.scm but was too slow */
5689 int len = 0;
5690 pointer newstr;
5691 char *pos;
5692
5693 /* compute needed length for new string */
5694 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
5695 len += strlength(car(x));
5696 }
5697 newstr = mk_empty_string(sc, len, ' ');
5698 /* store the contents of the argument strings into the new string */
5699 for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
5700 pos += strlength(car(x)), x = cdr(x)) {
5701 memcpy(pos, strvalue(car(x)), strlength(car(x)));
5702 }
5703 s_return(sc, newstr);
5704 }
5705
5706 case OP_SUBSTR: { /* substring */
5707 char *str;
5708 int index0;
5709 int index1;
5710 int len;
5711
5712 str=strvalue(car(sc->args));
5713
5714 index0=ivalue(cadr(sc->args));
5715
5716 if(index0>strlength(car(sc->args))) {
5717 Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
5718 }
5719
5720 if(cddr(sc->args)!=sc->NIL) {
5721 index1=ivalue(caddr(sc->args));
5722 if(index1>strlength(car(sc->args)) || index1<index0) {
5723 Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
5724 }
5725 } else {
5726 index1=strlength(car(sc->args));
5727 }
5728
5729 len=index1-index0;
5730 x=mk_empty_string(sc,len,' ');
5731 memcpy(strvalue(x),str+index0,len);
5732 strvalue(x)[len]=0;
5733
5734 s_return(sc,x);
5735 }
5736
5737 case OP_VECTOR: { /* vector */
5738 int i;
5739 pointer vec;
5740 int len=list_length(sc,sc->args);
5741 if(len<0) {
5742 Error_1(sc,"vector: not a proper list:",sc->args);
5743 }
5744 vec=mk_vector(sc,len);
5745 if(sc->no_memory) { s_return(sc, sc->sink); }
5746 for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
5747 set_vector_elem(vec,i,car(x));
5748 }
5749 s_return(sc,vec);
5750 }
5751
5752 case OP_MKVECTOR: { /* make-vector */
5753 pointer fill=sc->NIL;
5754 int len;
5755 pointer vec;
5756
5757 len=ivalue(car(sc->args));
5758
5759 if(cdr(sc->args)!=sc->NIL) {
5760 fill=cadr(sc->args);
5761 }
5762 vec=mk_vector(sc,len);
5763 if(sc->no_memory) { s_return(sc, sc->sink); }
5764 if(fill!=sc->NIL) {
5765 fill_vector(vec,fill);
5766 }
5767 s_return(sc,vec);
5768 }
5769
5770 case OP_VECLEN: /* vector-length */
5771 s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
5772
5773 case OP_VECREF: { /* vector-ref */
5774 int index;
5775
5776 index=ivalue(cadr(sc->args));
5777
5778 if(index>=ivalue(car(sc->args))) {
5779 Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
5780 }
5781
5782 s_return(sc,vector_elem(car(sc->args),index));
5783 }
5784
5785 case OP_VECSET: { /* vector-set! */
5786 int index;
5787
5788 if(is_immutable(car(sc->args))) {
5789 Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
5790 }
5791
5792 index=ivalue(cadr(sc->args));
5793 if(index>=ivalue(car(sc->args))) {
5794 Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
5795 }
5796
5797 set_vector_elem(car(sc->args),index,caddr(sc->args));
5798 s_return(sc,car(sc->args));
5799 }
5800
5801 default:
5802 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5803 Error_0(sc,sc->strbuff);
5804 }
5805 return sc->T;
5806 }
5807
5808 static int is_list(scheme *sc, pointer a)
5809 { return list_length(sc,a) >= 0; }
5810
5811 /* Result is:
5812 proper list: length
5813 circular list: -1
5814 not even a pair: -2
5815 dotted list: -2 minus length before dot
5816 */
5817 int list_length(scheme *sc, pointer a) {
5818 int i=0;
5819 pointer slow, fast;
5820
5821 slow = fast = a;
5822 while (1)
5823 {
5824 if (fast == sc->NIL)
5825 return i;
5826 if (!is_pair(fast))
5827 return -2 - i;
5828 fast = cdr(fast);
5829 ++i;
5830 if (fast == sc->NIL)
5831 return i;
5832 if (!is_pair(fast))
5833 return -2 - i;
5834 ++i;
5835 fast = cdr(fast);
5836
5837 /* Safe because we would have already returned if `fast'
5838 encountered a non-pair. */
5839 slow = cdr(slow);
5840 if (fast == slow)
5841 {
5842 /* the fast pointer has looped back around and caught up
5843 with the slow pointer, hence the structure is circular,
5844 not of finite length, and therefore not a list */
5845 return -1;
5846 }
5847 }
5848 }
5849
5850 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
5851 pointer x;
5852 num v;
5853 int (*comp_func)(num,num)=0;
5854
5855 switch (op) {
5856 case OP_NOT: /* not */
5857 s_retbool(is_false(car(sc->args)));
5858 case OP_BOOLP: /* boolean? */
5859 s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
5860 case OP_EOFOBJP: /* boolean? */
5861 s_retbool(car(sc->args) == sc->EOF_OBJ);
5862 case OP_NULLP: /* null? */
5863 s_retbool(car(sc->args) == sc->NIL);
5864 case OP_NUMEQ: /* = */
5865 case OP_LESS: /* < */
5866 case OP_GRE: /* > */
5867 case OP_LEQ: /* <= */
5868 case OP_GEQ: /* >= */
5869 switch(op) {
5870 case OP_NUMEQ: comp_func=num_eq; break;
5871 case OP_LESS: comp_func=num_lt; break;
5872 case OP_GRE: comp_func=num_gt; break;
5873 case OP_LEQ: comp_func=num_le; break;
5874 case OP_GEQ: comp_func=num_ge; break;
5875 }
5876 x=sc->args;
5877 v=nvalue(car(x));
5878 x=cdr(x);
5879
5880 for (; x != sc->NIL; x = cdr(x)) {
5881 if(!comp_func(v,nvalue(car(x)))) {
5882 s_retbool(0);
5883 }
5884 v=nvalue(car(x));
5885 }
5886 s_retbool(1);
5887 case OP_SYMBOLP: /* symbol? */
5888 s_retbool(is_symbol(car(sc->args)));
5889 case OP_NUMBERP: /* number? */
5890 s_retbool(is_number(car(sc->args)));
5891 case OP_STRINGP: /* string? */
5892 s_retbool(is_string(car(sc->args)));
5893 case OP_INTEGERP: /* integer? */
5894 s_retbool(is_integer(car(sc->args)));
5895 case OP_REALP: /* real? */
5896 s_retbool(is_number(car(sc->args))); /* All numbers are real */
5897 case OP_CHARP: /* char? */
5898 s_retbool(is_character(car(sc->args)));
5899 #if USE_CHAR_CLASSIFIERS
5900 case OP_CHARAP: /* char-alphabetic? */
5901 s_retbool(Cisalpha(ivalue(car(sc->args))));
5902 case OP_CHARNP: /* char-numeric? */
5903 s_retbool(Cisdigit(ivalue(car(sc->args))));
5904 case OP_CHARWP: /* char-whitespace? */
5905 s_retbool(Cisspace(ivalue(car(sc->args))));
5906 case OP_CHARUP: /* char-upper-case? */
5907 s_retbool(Cisupper(ivalue(car(sc->args))));
5908 case OP_CHARLP: /* char-lower-case? */
5909 s_retbool(Cislower(ivalue(car(sc->args))));
5910 #endif
5911 case OP_PORTP: /* port? */
5912 s_retbool(is_port(car(sc->args)));
5913 case OP_INPORTP: /* input-port? */
5914 s_retbool(is_inport(car(sc->args)));
5915 case OP_OUTPORTP: /* output-port? */
5916 s_retbool(is_outport(car(sc->args)));
5917 case OP_PROCP: /* procedure? */
5918 /*--
5919 * continuation should be procedure by the example
5920 * (call-with-current-continuation procedure?) ==> #t
5921 * in R^3 report sec. 6.9
5922 */
5923 s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
5924 || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
5925 case OP_PAIRP: /* pair? */
5926 s_retbool(is_pair(car(sc->args)));
5927 case OP_LISTP: /* list? */
5928 s_retbool(list_length(sc,car(sc->args)) >= 0);
5929
5930 case OP_ENVP: /* environment? */
5931 s_retbool(is_environment(car(sc->args)));
5932 case OP_VECTORP: /* vector? */
5933 s_retbool(is_vector(car(sc->args)));
5934 case OP_EQ: /* eq? */
5935 s_retbool(car(sc->args) == cadr(sc->args));
5936 case OP_EQV: /* eqv? */
5937 s_retbool(eqv(car(sc->args), cadr(sc->args)));
5938 default:
5939 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
5940 Error_0(sc,sc->strbuff);
5941 }
5942 return sc->T;
5943 }
5944
5945 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
5946 pointer x, y;
5947
5948 switch (op) {
5949 case OP_FORCE: /* force */
5950 sc->code = car(sc->args);
5951 if (is_promise(sc->code)) {
5952 /* Should change type to closure here */
5953 s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
5954 sc->args = sc->NIL;
5955 s_goto(sc,OP_APPLY);
5956 } else {
5957 s_return(sc,sc->code);
5958 }
5959
5960 case OP_SAVE_FORCED: /* Save forced value replacing promise */
5961 memcpy(sc->code,sc->value,sizeof(struct cell));
5962 s_return(sc,sc->value);
5963
5964 case OP_WRITE: /* write */
5965 case OP_DISPLAY: /* display */
5966 case OP_WRITE_CHAR: /* write-char */
5967 if(is_pair(cdr(sc->args))) {
5968 if(cadr(sc->args)!=sc->outport) {
5969 x=cons(sc,sc->outport,sc->NIL);
5970 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
5971 sc->outport=cadr(sc->args);
5972 }
5973 }
5974 sc->args = car(sc->args);
5975 if(op==OP_WRITE) {
5976 sc->print_flag = 1;
5977 } else {
5978 sc->print_flag = 0;
5979 }
5980 s_goto(sc,OP_P0LIST);
5981
5982 case OP_NEWLINE: /* newline */
5983 if(is_pair(sc->args)) {
5984 if(car(sc->args)!=sc->outport) {
5985 x=cons(sc,sc->outport,sc->NIL);
5986 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
5987 sc->outport=car(sc->args);
5988 }
5989 }
5990 putstr(sc, "\n");
5991 s_return(sc,sc->T);
5992
5993 case OP_ERR0: /* error */
5994 sc->retcode=-1;
5995 if (!is_string(car(sc->args))) {
5996 sc->args=cons(sc,mk_string(sc," -- "),sc->args);
5997 setimmutable(car(sc->args));
5998 }
5999 putstr(sc, "Error: ");
6000 putstr(sc, strvalue(car(sc->args)));
6001 sc->args = cdr(sc->args);
6002 s_goto(sc,OP_ERR1);
6003
6004 case OP_ERR1: /* error */
6005 putstr(sc, " ");
6006 if (sc->args != sc->NIL) {
6007 s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
6008 sc->args = car(sc->args);
6009 sc->print_flag = 1;
6010 s_goto(sc,OP_P0LIST);
6011 } else {
6012 putstr(sc, "\n");
6013 if(sc->interactive_repl) {
6014 s_goto(sc,OP_T0LVL);
6015 } else {
6016 return sc->NIL;
6017 }
6018 }
6019
6020 case OP_REVERSE: /* reverse */
6021 s_return(sc,reverse(sc, car(sc->args)));
6022
6023 case OP_LIST_STAR: /* list* */
6024 s_return(sc,list_star(sc,sc->args));
6025
6026 case OP_APPEND: /* append */
6027 x = sc->NIL;
6028 y = sc->args;
6029 if (y == x) {
6030 s_return(sc, x);
6031 }
6032
6033 /* cdr() in the while condition is not a typo. If car() */
6034 /* is used (append '() 'a) will return the wrong result.*/
6035 while (cdr(y) != sc->NIL) {
6036 x = revappend(sc, x, car(y));
6037 y = cdr(y);
6038 if (x == sc->F) {
6039 Error_0(sc, "non-list argument to append");
6040 }
6041 }
6042
6043 s_return(sc, reverse_in_place(sc, car(y), x));
6044
6045 #if USE_PLIST
6046 case OP_PUT: /* put */
6047 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
6048 Error_0(sc,"illegal use of put");
6049 }
6050 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
6051 if (caar(x) == y) {
6052 break;
6053 }
6054 }
6055 if (x != sc->NIL)
6056 cdar(x) = caddr(sc->args);
6057 else
6058 symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
6059 symprop(car(sc->args)));
6060 s_return(sc,sc->T);
6061
6062 case OP_GET: /* get */
6063 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
6064 Error_0(sc,"illegal use of get");
6065 }
6066 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
6067 if (caar(x) == y) {
6068 break;
6069 }
6070 }
6071 if (x != sc->NIL) {
6072 s_return(sc,cdar(x));
6073 } else {
6074 s_return(sc,sc->NIL);
6075 }
6076 #endif /* USE_PLIST */
6077 case OP_QUIT: /* quit */
6078 if(is_pair(sc->args)) {
6079 sc->retcode=ivalue(car(sc->args));
6080 }
6081 return (sc->NIL);
6082
6083 case OP_GC: /* gc */
6084 gc(sc, sc->NIL, sc->NIL);
6085 s_return(sc,sc->T);
6086
6087 case OP_GCVERB: /* gc-verbose */
6088 { int was = sc->gc_verbose;
6089
6090 sc->gc_verbose = (car(sc->args) != sc->F);
6091 s_retbool(was);
6092 }
6093
6094 case OP_NEWSEGMENT: /* new-segment */
6095 if (!is_pair(sc->args) || !is_number(car(sc->args))) {
6096 Error_0(sc,"new-segment: argument must be a number");
6097 }
6098 alloc_cellseg(sc, (int) ivalue(car(sc->args)));
6099 s_return(sc,sc->T);
6100
6101 case OP_OBLIST: /* oblist */
6102 s_return(sc, oblist_all_symbols(sc));
6103
6104 case OP_CURR_INPORT: /* current-input-port */
6105 s_return(sc,sc->inport);
6106
6107 case OP_CURR_OUTPORT: /* current-output-port */
6108 s_return(sc,sc->outport);
6109
6110 case OP_OPEN_INFILE: /* open-input-file */
6111 case OP_OPEN_OUTFILE: /* open-output-file */
6112 case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
6113 int prop=0;
6114 pointer p;
6115 switch(op) {
6116 case OP_OPEN_INFILE: prop=port_input; break;
6117 case OP_OPEN_OUTFILE: prop=port_output; break;
6118 case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
6119 }
6120 p=port_from_filename(sc,strvalue(car(sc->args)),prop);
6121 if(p==sc->NIL) {
6122 s_return(sc,sc->F);
6123 }
6124 s_return(sc,p);
6125 }
6126
6127 #if USE_STRING_PORTS
6128 case OP_OPEN_INSTRING: /* open-input-string */
6129 case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
6130 int prop=0;
6131 pointer p;
6132 switch(op) {
6133 case OP_OPEN_INSTRING: prop=port_input; break;
6134 case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
6135 }
6136 p=port_from_string(sc, strvalue(car(sc->args)),
6137 strvalue(car(sc->args))+strlength(car(sc->args)), prop);
6138 if(p==sc->NIL) {
6139 s_return(sc,sc->F);
6140 }
6141 s_return(sc,p);
6142 }
6143 case OP_OPEN_OUTSTRING: /* open-output-string */ {
6144 pointer p;
6145 if(car(sc->args)==sc->NIL) {
6146 p=port_from_scratch(sc);
6147 if(p==sc->NIL) {
6148 s_return(sc,sc->F);
6149 }
6150 } else {
6151 p=port_from_string(sc, strvalue(car(sc->args)),
6152 strvalue(car(sc->args))+strlength(car(sc->args)),
6153 port_output);
6154 if(p==sc->NIL) {
6155 s_return(sc,sc->F);
6156 }
6157 }
6158 s_return(sc,p);
6159 }
6160 case OP_GET_OUTSTRING: /* get-output-string */ {
6161 port *p;
6162
6163 if ((p=car(sc->args)->_object._port)->kind&port_string) {
6164 off_t size;
6165 char *str;
6166
6167 size=p->rep.string.curr-p->rep.string.start+1;
6168 str=sc->malloc(size);
6169 if(str != NULL) {
6170 pointer s;
6171
6172 memcpy(str,p->rep.string.start,size-1);
6173 str[size-1]='\0';
6174 s=mk_string(sc,str);
6175 sc->free(str);
6176 s_return(sc,s);
6177 }
6178 }
6179 s_return(sc,sc->F);
6180 }
6181 #endif
6182
6183 case OP_CLOSE_INPORT: /* close-input-port */
6184 port_close(sc,car(sc->args),port_input);
6185 s_return(sc,sc->T);
6186
6187 case OP_CLOSE_OUTPORT: /* close-output-port */
6188 port_close(sc,car(sc->args),port_output);
6189 s_return(sc,sc->T);
6190
6191 case OP_INT_ENV: /* interaction-environment */
6192 s_return(sc,sc->global_env);
6193
6194 case OP_CURR_ENV: /* current-environment */
6195 s_return(sc,sc->envir);
6196
6197 }
6198 return sc->T;
6199 }
6200
6201 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
6202 pointer x;
6203
6204 if(sc->nesting!=0) {
6205 int n=sc->nesting;
6206 sc->nesting=0;
6207 sc->retcode=-1;
6208 Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
6209 }
6210
6211 switch (op) {
6212 /* ========== reading part ========== */
6213 case OP_READ:
6214 if(!is_pair(sc->args)) {
6215 s_goto(sc,OP_READ_INTERNAL);
6216 }
6217 if(!is_inport(car(sc->args))) {
6218 Error_1(sc,"read: not an input port:",car(sc->args));
6219 }
6220 if(car(sc->args)==sc->inport) {
6221 s_goto(sc,OP_READ_INTERNAL);
6222 }
6223 x=sc->inport;
6224 sc->inport=car(sc->args);
6225 x=cons(sc,x,sc->NIL);
6226 s_save(sc,OP_SET_INPORT, x, sc->NIL);
6227 s_goto(sc,OP_READ_INTERNAL);
6228
6229 case OP_READ_CHAR: /* read-char */
6230 case OP_PEEK_CHAR: /* peek-char */ {
6231 int c;
6232 if(is_pair(sc->args)) {
6233 if(car(sc->args)!=sc->inport) {
6234 x=sc->inport;
6235 x=cons(sc,x,sc->NIL);
6236 s_save(sc,OP_SET_INPORT, x, sc->NIL);
6237 sc->inport=car(sc->args);
6238 }
6239 }
6240 c=inchar(sc);
6241 if(c==EOF) {
6242 s_return(sc,sc->EOF_OBJ);
6243 }
6244 if(sc->op==OP_PEEK_CHAR) {
6245 backchar(sc,c);
6246 }
6247 s_return(sc,mk_character(sc,c));
6248 }
6249
6250 case OP_CHAR_READY: /* char-ready? */ {
6251 pointer p=sc->inport;
6252 int res;
6253 if(is_pair(sc->args)) {
6254 p=car(sc->args);
6255 }
6256 res=p->_object._port->kind&port_string;
6257 s_retbool(res);
6258 }
6259
6260 case OP_SET_INPORT: /* set-input-port */
6261 sc->inport=car(sc->args);
6262 s_return(sc,sc->value);
6263
6264 case OP_SET_OUTPORT: /* set-output-port */
6265 sc->outport=car(sc->args);
6266 s_return(sc,sc->value);
6267
6268 case OP_RDSEXPR:
6269 switch (sc->tok) {
6270 case TOK_EOF:
6271 s_return(sc,sc->EOF_OBJ);
6272 /* NOTREACHED */
6273 /*
6274 * Commented out because we now skip comments in the scanner
6275 *
6276 case TOK_COMMENT: {
6277 int c;
6278 while ((c=inchar(sc)) != '\n' && c!=EOF)
6279 ;
6280 sc->tok = token(sc);
6281 s_goto(sc,OP_RDSEXPR);
6282 }
6283 */
6284 case TOK_VEC:
6285 s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
6286 /* fall through */
6287 case TOK_LPAREN:
6288 sc->tok = token(sc);
6289 if (sc->tok == TOK_RPAREN) {
6290 s_return(sc,sc->NIL);
6291 } else if (sc->tok == TOK_DOT) {
6292 Error_0(sc,"syntax error: illegal dot expression");
6293 } else {
6294 sc->nesting_stack[sc->file_i]++;
6295 s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
6296 s_goto(sc,OP_RDSEXPR);
6297 }
6298 case TOK_QUOTE:
6299 s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
6300 sc->tok = token(sc);
6301 s_goto(sc,OP_RDSEXPR);
6302 case TOK_BQUOTE:
6303 sc->tok = token(sc);
6304 if(sc->tok==TOK_VEC) {
6305 s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
6306 sc->tok=TOK_LPAREN;
6307 s_goto(sc,OP_RDSEXPR);
6308 } else {
6309 s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
6310 }
6311 s_goto(sc,OP_RDSEXPR);
6312 case TOK_COMMA:
6313 s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
6314 sc->tok = token(sc);
6315 s_goto(sc,OP_RDSEXPR);
6316 case TOK_ATMARK:
6317 s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
6318 sc->tok = token(sc);
6319 s_goto(sc,OP_RDSEXPR);
6320 case TOK_ATOM:
6321 s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
6322 case TOK_DQUOTE:
6323 x=readstrexp(sc);
6324 if(x==sc->F) {
6325 Error_0(sc,"Error reading string");
6326 }
6327 setimmutable(x);
6328 s_return(sc,x);
6329 case TOK_SHARP: {
6330 pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
6331 if(f==sc->NIL) {
6332 Error_0(sc,"undefined sharp expression");
6333 } else {
6334 sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
6335 s_goto(sc,OP_EVAL);
6336 }
6337 }
6338 case TOK_SHARP_CONST:
6339 if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
6340 Error_0(sc,"undefined sharp expression");
6341 } else {
6342 s_return(sc,x);
6343 }
6344 default:
6345 Error_0(sc,"syntax error: illegal token");
6346 }
6347 break;
6348
6349 case OP_RDLIST: {
6350 sc->args = cons(sc, sc->value, sc->args);
6351 sc->tok = token(sc);
6352 /* We now skip comments in the scanner
6353 while (sc->tok == TOK_COMMENT) {
6354 int c;
6355 while ((c=inchar(sc)) != '\n' && c!=EOF)
6356 ;
6357 sc->tok = token(sc);
6358 }
6359 */
6360 if (sc->tok == TOK_EOF)
6361 { s_return(sc,sc->EOF_OBJ); }
6362 else if (sc->tok == TOK_RPAREN) {
6363 int c = inchar(sc);
6364 if (c != '\n')
6365 backchar(sc,c);
6366 #if SHOW_ERROR_LINE
6367 else if (sc->load_stack[sc->file_i].kind & port_file)
6368 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
6369 #endif
6370 sc->nesting_stack[sc->file_i]--;
6371 s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
6372 } else if (sc->tok == TOK_DOT) {
6373 s_save(sc,OP_RDDOT, sc->args, sc->NIL);
6374 sc->tok = token(sc);
6375 s_goto(sc,OP_RDSEXPR);
6376 } else {
6377 s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
6378 s_goto(sc,OP_RDSEXPR);
6379 }
6380 }
6381
6382 case OP_RDDOT:
6383 if (token(sc) != TOK_RPAREN) {
6384 Error_0(sc,"syntax error: illegal dot expression");
6385 } else {
6386 sc->nesting_stack[sc->file_i]--;
6387 s_return(sc,reverse_in_place(sc, sc->value, sc->args));
6388 }
6389
6390 case OP_RDQUOTE:
6391 s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
6392
6393 case OP_RDQQUOTE:
6394 s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
6395
6396 case OP_RDQQUOTEVEC:
6397 s_return(sc,cons(sc, mk_symbol(sc,"apply"),
6398 cons(sc, mk_symbol(sc,"vector"),
6399 cons(sc,cons(sc, sc->QQUOTE,
6400 cons(sc,sc->value,sc->NIL)),
6401 sc->NIL))));
6402
6403 case OP_RDUNQUOTE:
6404 s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
6405
6406 case OP_RDUQTSP:
6407 s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
6408
6409 case OP_RDVEC:
6410 /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
6411 s_goto(sc,OP_EVAL); Cannot be quoted*/
6412 /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
6413 s_return(sc,x); Cannot be part of pairs*/
6414 /*sc->code=mk_proc(sc,OP_VECTOR);
6415 sc->args=sc->value;
6416 s_goto(sc,OP_APPLY);*/
6417 sc->args=sc->value;
6418 s_goto(sc,OP_VECTOR);
6419
6420 /* ========== printing part ========== */
6421 case OP_P0LIST:
6422 if(is_vector(sc->args)) {
6423 putstr(sc,"#(");
6424 sc->args=cons(sc,sc->args,mk_integer(sc,0));
6425 s_goto(sc,OP_PVECFROM);
6426 } else if(is_environment(sc->args)) {
6427 putstr(sc,"#<ENVIRONMENT>");
6428 s_return(sc,sc->T);
6429 } else if (!is_pair(sc->args)) {
6430 printatom(sc, sc->args, sc->print_flag);
6431 s_return(sc,sc->T);
6432 } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
6433 putstr(sc, "'");
6434 sc->args = cadr(sc->args);
6435 s_goto(sc,OP_P0LIST);
6436 } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
6437 putstr(sc, "`");
6438 sc->args = cadr(sc->args);
6439 s_goto(sc,OP_P0LIST);
6440 } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
6441 putstr(sc, ",");
6442 sc->args = cadr(sc->args);
6443 s_goto(sc,OP_P0LIST);
6444 } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
6445 putstr(sc, ",@");
6446 sc->args = cadr(sc->args);
6447 s_goto(sc,OP_P0LIST);
6448 } else {
6449 putstr(sc, "(");
6450 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
6451 sc->args = car(sc->args);
6452 s_goto(sc,OP_P0LIST);
6453 }
6454
6455 case OP_P1LIST:
6456 if (is_pair(sc->args)) {
6457 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
6458 putstr(sc, " ");
6459 sc->args = car(sc->args);
6460 s_goto(sc,OP_P0LIST);
6461 } else if(is_vector(sc->args)) {
6462 s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
6463 putstr(sc, " . ");
6464 s_goto(sc,OP_P0LIST);
6465 } else {
6466 if (sc->args != sc->NIL) {
6467 putstr(sc, " . ");
6468 printatom(sc, sc->args, sc->print_flag);
6469 }
6470 putstr(sc, ")");
6471 s_return(sc,sc->T);
6472 }
6473 case OP_PVECFROM: {
6474 int i=ivalue_unchecked(cdr(sc->args));
6475 pointer vec=car(sc->args);
6476 int len=ivalue_unchecked(vec);
6477 if(i==len) {
6478 putstr(sc,")");
6479 s_return(sc,sc->T);
6480 } else {
6481 pointer elem=vector_elem(vec,i);
6482 ivalue_unchecked(cdr(sc->args))=i+1;
6483 s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
6484 sc->args=elem;
6485 if (i > 0)
6486 putstr(sc," ");
6487 s_goto(sc,OP_P0LIST);
6488 }
6489 }
6490
6491 default:
6492 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
6493 Error_0(sc,sc->strbuff);
6494
6495 }
6496 return sc->T;
6497 }
6498
6499 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
6500 pointer x, y;
6501 long v;
6502
6503 switch (op) {
6504 case OP_LIST_LENGTH: /* length */ /* a.k */
6505 v=list_length(sc,car(sc->args));
6506 if(v<0) {
6507 Error_1(sc,"length: not a list:",car(sc->args));
6508 }
6509 s_return(sc,mk_integer(sc, v));
6510
6511 case OP_ASSQ: /* assq */ /* a.k */
6512 x = car(sc->args);
6513 for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
6514 if (!is_pair(car(y))) {
6515 Error_0(sc,"unable to handle non pair element");
6516 }
6517 if (x == caar(y))
6518 break;
6519 }
6520 if (is_pair(y)) {
6521 s_return(sc,car(y));
6522 } else {
6523 s_return(sc,sc->F);
6524 }
6525
6526
6527 case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
6528 sc->args = car(sc->args);
6529 if (sc->args == sc->NIL) {
6530 s_return(sc,sc->F);
6531 } else if (is_closure(sc->args)) {
6532 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
6533 } else if (is_macro(sc->args)) {
6534 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
6535 } else {
6536 s_return(sc,sc->F);
6537 }
6538 case OP_CLOSUREP: /* closure? */
6539 /*
6540 * Note, macro object is also a closure.
6541 * Therefore, (closure? <#MACRO>) ==> #t
6542 */
6543 s_retbool(is_closure(car(sc->args)));
6544 case OP_MACROP: /* macro? */
6545 s_retbool(is_macro(car(sc->args)));
6546 default:
6547 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
6548 Error_0(sc,sc->strbuff);
6549 }
6550 return sc->T; /* NOTREACHED */
6551 }
6552
6553 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
6554
6555 typedef int (*test_predicate)(pointer);
6556 static int is_any(pointer p) { return 1;}
6557
6558 static int is_nonneg(pointer p) {
6559 return ivalue(p)>=0 && is_integer(p);
6560 }
6561
6562 /* Correspond carefully with following defines! */
6563 static struct {
6564 test_predicate fct;
6565 const char *kind;
6566 } tests[]={
6567 {0,0}, /* unused */
6568 {is_any, 0},
6569 {is_string, "string"},
6570 {is_symbol, "symbol"},
6571 {is_port, "port"},
6572 {is_inport,"input port"},
6573 {is_outport,"output port"},
6574 {is_environment, "environment"},
6575 {is_pair, "pair"},
6576 {0, "pair or '()"},
6577 {is_character, "character"},
6578 {is_vector, "vector"},
6579 {is_number, "number"},
6580 {is_integer, "integer"},
6581 {is_nonneg, "non-negative integer"}
6582 };
6583
6584 #define TST_NONE 0
6585 #define TST_ANY "\001"
6586 #define TST_STRING "\002"
6587 #define TST_SYMBOL "\003"
6588 #define TST_PORT "\004"
6589 #define TST_INPORT "\005"
6590 #define TST_OUTPORT "\006"
6591 #define TST_ENVIRONMENT "\007"
6592 #define TST_PAIR "\010"
6593 #define TST_LIST "\011"
6594 #define TST_CHAR "\012"
6595 #define TST_VECTOR "\013"
6596 #define TST_NUMBER "\014"
6597 #define TST_INTEGER "\015"
6598 #define TST_NATURAL "\016"
6599
6600 typedef struct {
6601 dispatch_func func;
6602 char *name;
6603 int min_arity;
6604 int max_arity;
6605 char *arg_tests_encoding;
6606 } op_code_info;
6607
6608 #define INF_ARG 0xffff
6609
6610 static op_code_info dispatch_table[]= {
6611 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
6612 #include "opdefines.h"
6613 { 0 }
6614 };
6615
6616 static const char *procname(pointer x) {
6617 int n=procnum(x);
6618 const char *name=dispatch_table[n].name;
6619 if(name==0) {
6620 name="ILLEGAL!";
6621 }
6622 return name;
6623 }
6624
6625 /* kernel of this interpreter */
6626 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
6627 sc->op = op;
6628 for (;;) {
6629 op_code_info *pcd=dispatch_table+sc->op;
6630 if (pcd->name!=0) { /* if built-in function, check arguments */
6631 char msg[STRBUFFSIZE];
6632 int ok=1;
6633 int n=list_length(sc,sc->args);
6634
6635 /* Check number of arguments */
6636 if(n<pcd->min_arity) {
6637 ok=0;
6638 snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
6639 pcd->name,
6640 pcd->min_arity==pcd->max_arity?"":" at least",
6641 pcd->min_arity);
6642 }
6643 if(ok && n>pcd->max_arity) {
6644 ok=0;
6645 snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
6646 pcd->name,
6647 pcd->min_arity==pcd->max_arity?"":" at most",
6648 pcd->max_arity);
6649 }
6650 if(ok) {
6651 if(pcd->arg_tests_encoding!=0) {
6652 int i=0;
6653 int j;
6654 const char *t=pcd->arg_tests_encoding;
6655 pointer arglist=sc->args;
6656 do {
6657 pointer arg=car(arglist);
6658 j=(int)t[0];
6659 if(j==TST_LIST[0]) {
6660 if(arg!=sc->NIL && !is_pair(arg)) break;
6661 } else {
6662 if(!tests[j].fct(arg)) break;
6663 }
6664
6665 if(t[1]!=0) {/* last test is replicated as necessary */
6666 t++;
6667 }
6668 arglist=cdr(arglist);
6669 i++;
6670 } while(i<n);
6671 if(i<n) {
6672 ok=0;
6673 snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
6674 pcd->name,
6675 i+1,
6676 tests[j].kind);
6677 }
6678 }
6679 }
6680 if(!ok) {
6681 if(_Error_1(sc,msg,0)==sc->NIL) {
6682 return;
6683 }
6684 pcd=dispatch_table+sc->op;
6685 }
6686 }
6687 ok_to_freely_gc(sc);
6688 if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
6689 return;
6690 }
6691 if(sc->no_memory) {
6692 fprintf(stderr,"No memory!\n");
6693 return;
6694 }
6695 }
6696 }
6697
6698 /* ========== Initialization of internal keywords ========== */
6699
6700 static void assign_syntax(scheme *sc, char *name) {
6701 pointer x;
6702
6703 x = oblist_add_by_name(sc, name);
6704 typeflag(x) |= T_SYNTAX;
6705 }
6706
6707 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
6708 pointer x, y;
6709
6710 x = mk_symbol(sc, name);
6711 y = mk_proc(sc,op);
6712 new_slot_in_env(sc, x, y);
6713 }
6714
6715 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
6716 pointer y;
6717
6718 y = get_cell(sc, sc->NIL, sc->NIL);
6719 typeflag(y) = (T_PROC | T_ATOM);
6720 ivalue_unchecked(y) = (long) op;
6721 set_num_integer(y);
6722 return y;
6723 }
6724
6725 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
6726 static int syntaxnum(pointer p) {
6727 const char *s=strvalue(car(p));
6728 switch(strlength(car(p))) {
6729 case 2:
6730 if(s[0]=='i') return OP_IF0; /* if */
6731 else return OP_OR0; /* or */
6732 case 3:
6733 if(s[0]=='a') return OP_AND0; /* and */
6734 else return OP_LET0; /* let */
6735 case 4:
6736 switch(s[3]) {
6737 case 'e': return OP_CASE0; /* case */
6738 case 'd': return OP_COND0; /* cond */
6739 case '*': return OP_LET0AST; /* let* */
6740 default: return OP_SET0; /* set! */
6741 }
6742 case 5:
6743 switch(s[2]) {
6744 case 'g': return OP_BEGIN; /* begin */
6745 case 'l': return OP_DELAY; /* delay */
6746 case 'c': return OP_MACRO0; /* macro */
6747 default: return OP_QUOTE; /* quote */
6748 }
6749 case 6:
6750 switch(s[2]) {
6751 case 'm': return OP_LAMBDA; /* lambda */
6752 case 'f': return OP_DEF0; /* define */
6753 default: return OP_LET0REC; /* letrec */
6754 }
6755 default:
6756 return OP_C0STREAM; /* cons-stream */
6757 }
6758 }
6759
6760 /* initialization of TinyScheme */
6761 #if USE_INTERFACE
6762 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
6763 return cons(sc,a,b);
6764 }
6765 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
6766 return immutable_cons(sc,a,b);
6767 }
6768
6769 static struct scheme_interface vtbl ={
6770 scheme_define,
6771 s_cons,
6772 s_immutable_cons,
6773 reserve_cells,
6774 mk_integer,
6775 mk_real,
6776 mk_symbol,
6777 gensym,
6778 mk_string,
6779 mk_counted_string,
6780 mk_character,
6781 mk_vector,
6782 mk_foreign_func,
6783 putstr,
6784 putcharacter,
6785
6786 is_string,
6787 string_value,
6788 is_number,
6789 nvalue,
6790 ivalue,
6791 rvalue,
6792 is_integer,
6793 is_real,
6794 is_character,
6795 charvalue,
6796 is_list,
6797 is_vector,
6798 list_length,
6799 ivalue,
6800 fill_vector,
6801 vector_elem,
6802 set_vector_elem,
6803 is_port,
6804 is_pair,
6805 pair_car,
6806 pair_cdr,
6807 set_car,
6808 set_cdr,
6809
6810 is_symbol,
6811 symname,
6812
6813 is_syntax,
6814 is_proc,
6815 is_foreign,
6816 syntaxname,
6817 is_closure,
6818 is_macro,
6819 closure_code,
6820 closure_env,
6821
6822 is_continuation,
6823 is_promise,
6824 is_environment,
6825 is_immutable,
6826 setimmutable,
6827
6828 scheme_load_file,
6829 scheme_load_string
6830 };
6831 #endif
6832
6833 scheme *scheme_init_new() {
6834 scheme *sc=(scheme*)malloc(sizeof(scheme));
6835 if(!scheme_init(sc)) {
6836 free(sc);
6837 return 0;
6838 } else {
6839 return sc;
6840 }
6841 }
6842
6843 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
6844 scheme *sc=(scheme*)malloc(sizeof(scheme));
6845 if(!scheme_init_custom_alloc(sc,malloc,free)) {
6846 free(sc);
6847 return 0;
6848 } else {
6849 return sc;
6850 }
6851 }
6852
6853
6854 int scheme_init(scheme *sc) {
6855 return scheme_init_custom_alloc(sc,malloc,free);
6856 }
6857
6858 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
6859 int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
6860 pointer x;
6861
6862 /* fix unitialized free under Mac OS X */
6863 memset( sc->load_stack, 0, sizeof(port) * MAXFIL );
6864
6865 num_zero.is_fixnum=1;
6866 num_zero.value.ivalue=0;
6867 num_one.is_fixnum=1;
6868 num_one.value.ivalue=1;
6869
6870 #if USE_INTERFACE
6871 sc->vptr=&vtbl;
6872 #endif
6873 sc->gensym_cnt=0;
6874 sc->malloc=malloc;
6875 sc->free=free;
6876 sc->last_cell_seg = -1;
6877 sc->sink = &sc->_sink;
6878 sc->NIL = &sc->_NIL;
6879 sc->T = &sc->_HASHT;
6880 sc->F = &sc->_HASHF;
6881 sc->EOF_OBJ=&sc->_EOF_OBJ;
6882 sc->free_cell = &sc->_NIL;
6883 sc->fcells = 0;
6884 sc->no_memory=0;
6885 sc->inport=sc->NIL;
6886 sc->outport=sc->NIL;
6887 sc->save_inport=sc->NIL;
6888 sc->loadport=sc->NIL;
6889 sc->nesting=0;
6890 sc->interactive_repl=0;
6891
6892 if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
6893 sc->no_memory=1;
6894 return 0;
6895 }
6896 sc->gc_verbose = 0;
6897 dump_stack_initialize(sc);
6898 sc->code = sc->NIL;
6899 sc->tracing=0;
6900
6901 /* init sc->NIL */
6902 typeflag(sc->NIL) = (T_ATOM | MARK);
6903 car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
6904 /* init T */
6905 typeflag(sc->T) = (T_ATOM | MARK);
6906 car(sc->T) = cdr(sc->T) = sc->T;
6907 /* init F */
6908 typeflag(sc->F) = (T_ATOM | MARK);
6909 car(sc->F) = cdr(sc->F) = sc->F;
6910 /* init sink */
6911 typeflag(sc->sink) = (T_PAIR | MARK);
6912 car(sc->sink) = sc->NIL;
6913 /* init c_nest */
6914 sc->c_nest = sc->NIL;
6915
6916 sc->oblist = oblist_initial_value(sc);
6917 /* init global_env */
6918 new_frame_in_env(sc, sc->NIL);
6919 sc->global_env = sc->envir;
6920 /* init else */
6921 x = mk_symbol(sc,"else");
6922 new_slot_in_env(sc, x, sc->T);
6923
6924 assign_syntax(sc, "lambda");
6925 assign_syntax(sc, "quote");
6926 assign_syntax(sc, "define");
6927 assign_syntax(sc, "if");
6928 assign_syntax(sc, "begin");
6929 assign_syntax(sc, "set!");
6930 assign_syntax(sc, "let");
6931 assign_syntax(sc, "let*");
6932 assign_syntax(sc, "letrec");
6933 assign_syntax(sc, "cond");
6934 assign_syntax(sc, "delay");
6935 assign_syntax(sc, "and");
6936 assign_syntax(sc, "or");
6937 assign_syntax(sc, "cons-stream");
6938 assign_syntax(sc, "macro");
6939 assign_syntax(sc, "case");
6940
6941 for(i=0; i<n; i++) {
6942 if(dispatch_table[i].name!=0) {
6943 assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
6944 }
6945 }
6946
6947 /* initialization of global pointers to special symbols */
6948 sc->LAMBDA = mk_symbol(sc, "lambda");
6949 sc->QUOTE = mk_symbol(sc, "quote");
6950 sc->QQUOTE = mk_symbol(sc, "quasiquote");
6951 sc->UNQUOTE = mk_symbol(sc, "unquote");
6952 sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
6953 sc->FEED_TO = mk_symbol(sc, "=>");
6954 sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
6955 sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
6956 sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
6957 sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
6958
6959 return !sc->no_memory;
6960 }
6961
6962 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
6963 sc->inport=port_from_file(sc,fin,port_input);
6964 }
6965
6966 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
6967 sc->inport=port_from_string(sc,start,past_the_end,port_input);
6968 }
6969
6970 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
6971 sc->outport=port_from_file(sc,fout,port_output);
6972 }
6973
6974 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
6975 sc->outport=port_from_string(sc,start,past_the_end,port_output);
6976 }
6977
6978 void scheme_set_external_data(scheme *sc, void *p) {
6979 sc->ext_data=p;
6980 }
6981
6982 void scheme_deinit(scheme *sc) {
6983 int i;
6984
6985 #if SHOW_ERROR_LINE
6986 char *fname;
6987 #endif
6988
6989 sc->oblist=sc->NIL;
6990 sc->global_env=sc->NIL;
6991 dump_stack_free(sc);
6992 sc->envir=sc->NIL;
6993 sc->code=sc->NIL;
6994 sc->args=sc->NIL;
6995 sc->value=sc->NIL;
6996 if(is_port(sc->inport)) {
6997 typeflag(sc->inport) = T_ATOM;
6998 }
6999 sc->inport=sc->NIL;
7000 sc->outport=sc->NIL;
7001 if(is_port(sc->save_inport)) {
7002 typeflag(sc->save_inport) = T_ATOM;
7003 }
7004 sc->save_inport=sc->NIL;
7005 if(is_port(sc->loadport)) {
7006 typeflag(sc->loadport) = T_ATOM;
7007 }
7008 sc->loadport=sc->NIL;
7009 sc->gc_verbose=0;
7010 gc(sc,sc->NIL,sc->NIL);
7011
7012 for(i=0; i<=sc->last_cell_seg; i++) {
7013 sc->free(sc->alloc_seg[i]);
7014 }
7015
7016 #if SHOW_ERROR_LINE
7017 for(i=0; i<=sc->file_i; i++) {
7018 if (sc->load_stack[i].kind & port_file) {
7019 fname = sc->load_stack[i].rep.stdio.filename;
7020 if(fname)
7021 sc->free(fname);
7022 }
7023 }
7024 #endif
7025 }
7026
7027 void scheme_load_file(scheme *sc, FILE *fin)
7028 { scheme_load_named_file(sc,fin,0); }
7029
7030 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
7031 int interactive_repl = sc->interactive_repl && !filename;
7032 dump_stack_reset(sc);
7033 sc->envir = sc->global_env;
7034 sc->file_i=0;
7035 sc->load_stack[0].kind=port_input|port_file;
7036 sc->load_stack[0].rep.stdio.file=fin;
7037 sc->load_stack[0].rep.stdio.interactive=interactive_repl;
7038 sc->loadport=mk_port(sc,sc->load_stack);
7039 sc->retcode=0;
7040 if(interactive_repl) {
7041 sc->interactive_repl=interactive_repl;
7042 }
7043
7044 #if SHOW_ERROR_LINE
7045 sc->load_stack[0].rep.stdio.curr_line = 0;
7046 if(fin!=stdin && filename)
7047 sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
7048 #endif
7049
7050 sc->inport=sc->loadport;
7051 sc->args = mk_integer(sc,sc->file_i);
7052 Eval_Cycle(sc, OP_T0LVL);
7053 typeflag(sc->loadport)=T_ATOM;
7054 if(sc->retcode==0) {
7055 sc->retcode=sc->nesting!=0;
7056 }
7057 }
7058
7059 void scheme_load_string(scheme *sc, const char *cmd) {
7060 dump_stack_reset(sc);
7061 sc->envir = sc->global_env;
7062 sc->file_i=0;
7063 sc->load_stack[0].kind=port_input|port_string;
7064 sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
7065 sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
7066 sc->load_stack[0].rep.string.curr=(char*)cmd;
7067 sc->loadport=mk_port(sc,sc->load_stack);
7068 sc->retcode=0;
7069 sc->interactive_repl=0;
7070 sc->inport=sc->loadport;
7071 sc->args = mk_integer(sc,sc->file_i);
7072 Eval_Cycle(sc, OP_T0LVL);
7073 typeflag(sc->loadport)=T_ATOM;
7074 if(sc->retcode==0) {
7075 sc->retcode=sc->nesting!=0;
7076 }
7077 }
7078
7079 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
7080 pointer x;
7081
7082 x=find_slot_in_env(sc,envir,symbol,0);
7083 if (x != sc->NIL) {
7084 set_slot_in_env(sc, x, value);
7085 } else {
7086 new_slot_spec_in_env(sc, envir, symbol, value);
7087 }
7088 }
7089
7090 #if !STANDALONE
7091 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
7092 {
7093 scheme_define(sc,
7094 sc->global_env,
7095 mk_symbol(sc,sr->name),
7096 mk_foreign_func(sc, sr->f));
7097 }
7098
7099 void scheme_register_foreign_func_list(scheme * sc,
7100 scheme_registerable * list,
7101 int count)
7102 {
7103 int i;
7104 for(i = 0; i < count; i++)
7105 {
7106 scheme_register_foreign_func(sc, list + i);
7107 }
7108 }
7109
7110 pointer scheme_apply0(scheme *sc, const char *procname)
7111 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
7112
7113 void save_from_C_call(scheme *sc)
7114 {
7115 pointer saved_data =
7116 cons(sc,
7117 car(sc->sink),
7118 cons(sc,
7119 sc->envir,
7120 sc->dump));
7121 /* Push */
7122 sc->c_nest = cons(sc, saved_data, sc->c_nest);
7123 /* Truncate the dump stack so TS will return here when done, not
7124 directly resume pre-C-call operations. */
7125 dump_stack_reset(sc);
7126 }
7127 void restore_from_C_call(scheme *sc)
7128 {
7129 car(sc->sink) = caar(sc->c_nest);
7130 sc->envir = cadar(sc->c_nest);
7131 sc->dump = cdr(cdar(sc->c_nest));
7132 /* Pop */
7133 sc->c_nest = cdr(sc->c_nest);
7134 }
7135
7136 /* "func" and "args" are assumed to be already eval'ed. */
7137 pointer scheme_call(scheme *sc, pointer func, pointer args)
7138 {
7139 int old_repl = sc->interactive_repl;
7140 sc->interactive_repl = 0;
7141 save_from_C_call(sc);
7142 sc->envir = sc->global_env;
7143 sc->args = args;
7144 sc->code = func;
7145 sc->retcode = 0;
7146 Eval_Cycle(sc, OP_APPLY);
7147 sc->interactive_repl = old_repl;
7148 restore_from_C_call(sc);
7149 return sc->value;
7150 }
7151
7152 pointer scheme_eval(scheme *sc, pointer obj)
7153 {
7154 int old_repl = sc->interactive_repl;
7155 sc->interactive_repl = 0;
7156 save_from_C_call(sc);
7157 sc->args = sc->NIL;
7158 sc->code = obj;
7159 sc->retcode = 0;
7160 Eval_Cycle(sc, OP_EVAL);
7161 sc->interactive_repl = old_repl;
7162 restore_from_C_call(sc);
7163 return sc->value;
7164 }
7165
7166
7167 #endif
7168
7169 /* ========== Main ========== */
7170
7171 #if STANDALONE
7172
7173 int main(int argc, char **argv) {
7174 scheme sc;
7175 FILE *fin;
7176 char *file_name=InitFile;
7177 int retcode;
7178 int isfile=1;
7179
7180 if(argc==1) {
7181 printf(banner);
7182 }
7183 if(argc==2 && strcmp(argv[1],"-?")==0) {
7184 printf("Usage: tinyscheme -?\n");
7185 printf("or: tinyscheme [<file1> <file2> ...]\n");
7186 printf("followed by\n");
7187 printf(" -1 <file> [<arg1> <arg2> ...]\n");
7188 printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n");
7189 printf("assuming that the executable is named tinyscheme.\n");
7190 printf("Use - as filename for stdin.\n");
7191 return 1;
7192 }
7193 if(!scheme_init(&sc)) {
7194 fprintf(stderr,"Could not initialize!\n");
7195 return 2;
7196 }
7197 scheme_set_input_port_file(&sc, stdin);
7198 scheme_set_output_port_file(&sc, stdout);
7199 argv++;
7200 if(access(file_name,0)!=0) {
7201 char *p=getenv("TINYSCHEMEINIT");
7202 if(p!=0) {
7203 file_name=p;
7204 }
7205 }
7206 do {
7207 if(strcmp(file_name,"-")==0) {
7208 fin=stdin;
7209 } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
7210 pointer args=sc.NIL;
7211 isfile=file_name[1]=='1';
7212 file_name=*argv++;
7213 if(strcmp(file_name,"-")==0) {
7214 fin=stdin;
7215 } else if(isfile) {
7216 fin=fopen(file_name,"r");
7217 }
7218 for(;*argv;argv++) {
7219 pointer value=mk_string(&sc,*argv);
7220 args=cons(&sc,value,args);
7221 }
7222 args=reverse_in_place(&sc,sc.NIL,args);
7223 scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
7224
7225 } else {
7226 fin=fopen(file_name,"r");
7227 }
7228 if(isfile && fin==0) {
7229 fprintf(stderr,"Could not open file %s\n",file_name);
7230 } else {
7231 if(isfile) {
7232 scheme_load_named_file(&sc,fin,file_name);
7233 } else {
7234 scheme_load_string(&sc,file_name);
7235 }
7236 if(!isfile || fin!=stdin) {
7237 if(sc.retcode!=0) {
7238 fprintf(stderr,"Errors encountered reading %s\n",file_name);
7239 }
7240 if(isfile) {
7241 fclose(fin);
7242 }
7243 }
7244 }
7245 file_name=*argv++;
7246 } while(file_name!=0);
7247 if(argc==1) {
7248 scheme_load_named_file(&sc,stdin,0);
7249 }
7250 retcode=sc.retcode;
7251 scheme_deinit(&sc);
7252
7253 return retcode;
7254 }
7255
7256 #endif