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