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