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