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
asciilifeform_tin... 16
tinyscheme_genesi... 17 #include "scheme-private.h"
asciilifeform_tin... 18 #include <unistd.h>
asciilifeform_tin... 19 #include <sys/types.h>
asciilifeform_tin... 20
tinyscheme_genesi... 21 #if USE_MATH
tinyscheme_genesi... 22 # include <math.h>
tinyscheme_genesi... 23 #endif
tinyscheme_genesi... 24
tinyscheme_genesi... 25 #include <limits.h>
tinyscheme_genesi... 26 #include <float.h>
tinyscheme_genesi... 27 #include <ctype.h>
tinyscheme_genesi... 28
tinyscheme_genesi... 29 #if USE_STRCASECMP
tinyscheme_genesi... 30 #include <strings.h>
tinyscheme_genesi... 31 # ifndef __APPLE__
tinyscheme_genesi... 32 # define stricmp strcasecmp
tinyscheme_genesi... 33 # endif
tinyscheme_genesi... 34 #endif
tinyscheme_genesi... 35
asciilifeform_tin... 36 const char* tiny_scheme_version = PACKAGE_VERSION;
asciilifeform_tin... 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) {
asciilifeform_tin... 1362 return sc->file_i==0 && sc->load_stack[0].rep.stdio.interactive
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;
asciilifeform_tin... 1383 pt->rep.stdio.interactive=0;
tinyscheme_genesi... 1384
tinyscheme_genesi... 1385 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1386 if(fn)
tinyscheme_genesi... 1387 pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
tinyscheme_genesi... 1388
tinyscheme_genesi... 1389 pt->rep.stdio.curr_line = 0;
tinyscheme_genesi... 1390 #endif
tinyscheme_genesi... 1391 return pt;
tinyscheme_genesi... 1392 }
tinyscheme_genesi... 1393
tinyscheme_genesi... 1394 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
tinyscheme_genesi... 1395 port *pt;
tinyscheme_genesi... 1396 pt=port_rep_from_filename(sc,fn,prop);
tinyscheme_genesi... 1397 if(pt==0) {
tinyscheme_genesi... 1398 return sc->NIL;
tinyscheme_genesi... 1399 }
tinyscheme_genesi... 1400 return mk_port(sc,pt);
tinyscheme_genesi... 1401 }
tinyscheme_genesi... 1402
tinyscheme_genesi... 1403 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
tinyscheme_genesi... 1404 {
tinyscheme_genesi... 1405 port *pt;
tinyscheme_genesi... 1406
tinyscheme_genesi... 1407 pt = (port *)sc->malloc(sizeof *pt);
tinyscheme_genesi... 1408 if (pt == NULL) {
tinyscheme_genesi... 1409 return NULL;
tinyscheme_genesi... 1410 }
tinyscheme_genesi... 1411 pt->kind = port_file | prop;
tinyscheme_genesi... 1412 pt->rep.stdio.file = f;
tinyscheme_genesi... 1413 pt->rep.stdio.closeit = 0;
asciilifeform_tin... 1414 pt->rep.stdio.interactive=sc->interactive_repl;
tinyscheme_genesi... 1415 return pt;
tinyscheme_genesi... 1416 }
tinyscheme_genesi... 1417
tinyscheme_genesi... 1418 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
tinyscheme_genesi... 1419 port *pt;
tinyscheme_genesi... 1420 pt=port_rep_from_file(sc,f,prop);
tinyscheme_genesi... 1421 if(pt==0) {
tinyscheme_genesi... 1422 return sc->NIL;
tinyscheme_genesi... 1423 }
tinyscheme_genesi... 1424 return mk_port(sc,pt);
tinyscheme_genesi... 1425 }
tinyscheme_genesi... 1426
tinyscheme_genesi... 1427 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
tinyscheme_genesi... 1428 port *pt;
tinyscheme_genesi... 1429 pt=(port*)sc->malloc(sizeof(port));
tinyscheme_genesi... 1430 if(pt==0) {
tinyscheme_genesi... 1431 return 0;
tinyscheme_genesi... 1432 }
tinyscheme_genesi... 1433 pt->kind=port_string|prop;
tinyscheme_genesi... 1434 pt->rep.string.start=start;
tinyscheme_genesi... 1435 pt->rep.string.curr=start;
tinyscheme_genesi... 1436 pt->rep.string.past_the_end=past_the_end;
tinyscheme_genesi... 1437 return pt;
tinyscheme_genesi... 1438 }
tinyscheme_genesi... 1439
tinyscheme_genesi... 1440 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
tinyscheme_genesi... 1441 port *pt;
tinyscheme_genesi... 1442 pt=port_rep_from_string(sc,start,past_the_end,prop);
tinyscheme_genesi... 1443 if(pt==0) {
tinyscheme_genesi... 1444 return sc->NIL;
tinyscheme_genesi... 1445 }
tinyscheme_genesi... 1446 return mk_port(sc,pt);
tinyscheme_genesi... 1447 }
tinyscheme_genesi... 1448
tinyscheme_genesi... 1449 #define BLOCK_SIZE 256
tinyscheme_genesi... 1450
tinyscheme_genesi... 1451 static port *port_rep_from_scratch(scheme *sc) {
tinyscheme_genesi... 1452 port *pt;
tinyscheme_genesi... 1453 char *start;
tinyscheme_genesi... 1454 pt=(port*)sc->malloc(sizeof(port));
tinyscheme_genesi... 1455 if(pt==0) {
tinyscheme_genesi... 1456 return 0;
tinyscheme_genesi... 1457 }
tinyscheme_genesi... 1458 start=sc->malloc(BLOCK_SIZE);
tinyscheme_genesi... 1459 if(start==0) {
tinyscheme_genesi... 1460 return 0;
tinyscheme_genesi... 1461 }
tinyscheme_genesi... 1462 memset(start,' ',BLOCK_SIZE-1);
tinyscheme_genesi... 1463 start[BLOCK_SIZE-1]='\0';
tinyscheme_genesi... 1464 pt->kind=port_string|port_output|port_srfi6;
tinyscheme_genesi... 1465 pt->rep.string.start=start;
tinyscheme_genesi... 1466 pt->rep.string.curr=start;
tinyscheme_genesi... 1467 pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
tinyscheme_genesi... 1468 return pt;
tinyscheme_genesi... 1469 }
tinyscheme_genesi... 1470
tinyscheme_genesi... 1471 static pointer port_from_scratch(scheme *sc) {
tinyscheme_genesi... 1472 port *pt;
tinyscheme_genesi... 1473 pt=port_rep_from_scratch(sc);
tinyscheme_genesi... 1474 if(pt==0) {
tinyscheme_genesi... 1475 return sc->NIL;
tinyscheme_genesi... 1476 }
tinyscheme_genesi... 1477 return mk_port(sc,pt);
tinyscheme_genesi... 1478 }
tinyscheme_genesi... 1479
tinyscheme_genesi... 1480 static void port_close(scheme *sc, pointer p, int flag) {
tinyscheme_genesi... 1481 port *pt=p->_object._port;
tinyscheme_genesi... 1482 pt->kind&=~flag;
tinyscheme_genesi... 1483 if((pt->kind & (port_input|port_output))==0) {
tinyscheme_genesi... 1484 if(pt->kind&port_file) {
tinyscheme_genesi... 1485
tinyscheme_genesi... 1486 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1487
tinyscheme_genesi... 1488 pt->rep.stdio.curr_line = 0;
tinyscheme_genesi... 1489
tinyscheme_genesi... 1490 if(pt->rep.stdio.filename)
tinyscheme_genesi... 1491 sc->free(pt->rep.stdio.filename);
tinyscheme_genesi... 1492 #endif
tinyscheme_genesi... 1493
tinyscheme_genesi... 1494 fclose(pt->rep.stdio.file);
tinyscheme_genesi... 1495 }
tinyscheme_genesi... 1496 pt->kind=port_free;
tinyscheme_genesi... 1497 }
tinyscheme_genesi... 1498 }
tinyscheme_genesi... 1499
tinyscheme_genesi... 1500
tinyscheme_genesi... 1501 static int inchar(scheme *sc) {
tinyscheme_genesi... 1502 int c;
tinyscheme_genesi... 1503 port *pt;
tinyscheme_genesi... 1504
tinyscheme_genesi... 1505 pt = sc->inport->_object._port;
tinyscheme_genesi... 1506 if(pt->kind & port_saw_EOF)
tinyscheme_genesi... 1507 { return EOF; }
tinyscheme_genesi... 1508 c = basic_inchar(pt);
tinyscheme_genesi... 1509 if(c == EOF && sc->inport == sc->loadport) {
tinyscheme_genesi... 1510
tinyscheme_genesi... 1511 pt->kind |= port_saw_EOF;
tinyscheme_genesi... 1512
tinyscheme_genesi... 1513
tinyscheme_genesi... 1514 return EOF;
tinyscheme_genesi... 1515
tinyscheme_genesi... 1516 }
tinyscheme_genesi... 1517 return c;
tinyscheme_genesi... 1518 }
tinyscheme_genesi... 1519
tinyscheme_genesi... 1520 static int basic_inchar(port *pt) {
tinyscheme_genesi... 1521 if(pt->kind & port_file) {
tinyscheme_genesi... 1522 return fgetc(pt->rep.stdio.file);
tinyscheme_genesi... 1523 } else {
tinyscheme_genesi... 1524 if(*pt->rep.string.curr == 0 ||
tinyscheme_genesi... 1525 pt->rep.string.curr == pt->rep.string.past_the_end) {
tinyscheme_genesi... 1526 return EOF;
tinyscheme_genesi... 1527 } else {
tinyscheme_genesi... 1528 return *pt->rep.string.curr++;
tinyscheme_genesi... 1529 }
tinyscheme_genesi... 1530 }
tinyscheme_genesi... 1531 }
tinyscheme_genesi... 1532
tinyscheme_genesi... 1533
tinyscheme_genesi... 1534 static void backchar(scheme *sc, int c) {
tinyscheme_genesi... 1535 port *pt;
tinyscheme_genesi... 1536 if(c==EOF) return;
tinyscheme_genesi... 1537 pt=sc->inport->_object._port;
tinyscheme_genesi... 1538 if(pt->kind&port_file) {
tinyscheme_genesi... 1539 ungetc(c,pt->rep.stdio.file);
tinyscheme_genesi... 1540 } else {
tinyscheme_genesi... 1541 if(pt->rep.string.curr!=pt->rep.string.start) {
tinyscheme_genesi... 1542 --pt->rep.string.curr;
tinyscheme_genesi... 1543 }
tinyscheme_genesi... 1544 }
tinyscheme_genesi... 1545 }
tinyscheme_genesi... 1546
tinyscheme_genesi... 1547 static int realloc_port_string(scheme *sc, port *p)
tinyscheme_genesi... 1548 {
tinyscheme_genesi... 1549 char *start=p->rep.string.start;
tinyscheme_genesi... 1550 size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
tinyscheme_genesi... 1551 char *str=sc->malloc(new_size);
tinyscheme_genesi... 1552 if(str) {
tinyscheme_genesi... 1553 memset(str,' ',new_size-1);
tinyscheme_genesi... 1554 str[new_size-1]='\0';
tinyscheme_genesi... 1555 strcpy(str,start);
tinyscheme_genesi... 1556 p->rep.string.start=str;
tinyscheme_genesi... 1557 p->rep.string.past_the_end=str+new_size-1;
tinyscheme_genesi... 1558 p->rep.string.curr-=start-str;
tinyscheme_genesi... 1559 sc->free(start);
tinyscheme_genesi... 1560 return 1;
tinyscheme_genesi... 1561 } else {
tinyscheme_genesi... 1562 return 0;
tinyscheme_genesi... 1563 }
tinyscheme_genesi... 1564 }
tinyscheme_genesi... 1565
tinyscheme_genesi... 1566 INTERFACE void putstr(scheme *sc, const char *s) {
tinyscheme_genesi... 1567 port *pt=sc->outport->_object._port;
tinyscheme_genesi... 1568 if(pt->kind&port_file) {
tinyscheme_genesi... 1569 fputs(s,pt->rep.stdio.file);
asciilifeform_tin... 1570 if( pt->rep.stdio.interactive )
asciilifeform_tin... 1571 fflush( pt->rep.stdio.file );
tinyscheme_genesi... 1572 } else {
tinyscheme_genesi... 1573 for(;*s;s++) {
tinyscheme_genesi... 1574 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
tinyscheme_genesi... 1575 *pt->rep.string.curr++=*s;
tinyscheme_genesi... 1576 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
tinyscheme_genesi... 1577 *pt->rep.string.curr++=*s;
tinyscheme_genesi... 1578 }
tinyscheme_genesi... 1579 }
tinyscheme_genesi... 1580 }
tinyscheme_genesi... 1581 }
tinyscheme_genesi... 1582
tinyscheme_genesi... 1583 static void putchars(scheme *sc, const char *s, int len) {
tinyscheme_genesi... 1584 port *pt=sc->outport->_object._port;
tinyscheme_genesi... 1585 if(pt->kind&port_file) {
tinyscheme_genesi... 1586 fwrite(s,1,len,pt->rep.stdio.file);
tinyscheme_genesi... 1587 } else {
tinyscheme_genesi... 1588 for(;len;len--) {
tinyscheme_genesi... 1589 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
tinyscheme_genesi... 1590 *pt->rep.string.curr++=*s++;
tinyscheme_genesi... 1591 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
tinyscheme_genesi... 1592 *pt->rep.string.curr++=*s++;
tinyscheme_genesi... 1593 }
tinyscheme_genesi... 1594 }
tinyscheme_genesi... 1595 }
tinyscheme_genesi... 1596 }
tinyscheme_genesi... 1597
tinyscheme_genesi... 1598 INTERFACE void putcharacter(scheme *sc, int c) {
tinyscheme_genesi... 1599 port *pt=sc->outport->_object._port;
tinyscheme_genesi... 1600 if(pt->kind&port_file) {
tinyscheme_genesi... 1601 fputc(c,pt->rep.stdio.file);
tinyscheme_genesi... 1602 } else {
tinyscheme_genesi... 1603 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
tinyscheme_genesi... 1604 *pt->rep.string.curr++=c;
tinyscheme_genesi... 1605 } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
tinyscheme_genesi... 1606 *pt->rep.string.curr++=c;
tinyscheme_genesi... 1607 }
tinyscheme_genesi... 1608 }
tinyscheme_genesi... 1609 }
tinyscheme_genesi... 1610
tinyscheme_genesi... 1611
tinyscheme_genesi... 1612 static char *readstr_upto(scheme *sc, char *delim) {
tinyscheme_genesi... 1613 char *p = sc->strbuff;
tinyscheme_genesi... 1614
tinyscheme_genesi... 1615 while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
tinyscheme_genesi... 1616 !is_one_of(delim, (*p++ = inchar(sc))));
tinyscheme_genesi... 1617
tinyscheme_genesi... 1618 if(p == sc->strbuff+2 && p[-2] == '\\') {
tinyscheme_genesi... 1619 *p=0;
tinyscheme_genesi... 1620 } else {
tinyscheme_genesi... 1621 backchar(sc,p[-1]);
tinyscheme_genesi... 1622 *--p = '\0';
tinyscheme_genesi... 1623 }
tinyscheme_genesi... 1624 return sc->strbuff;
tinyscheme_genesi... 1625 }
tinyscheme_genesi... 1626
tinyscheme_genesi... 1627
tinyscheme_genesi... 1628 static pointer readstrexp(scheme *sc) {
tinyscheme_genesi... 1629 char *p = sc->strbuff;
tinyscheme_genesi... 1630 int c;
tinyscheme_genesi... 1631 int c1=0;
tinyscheme_genesi... 1632 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
tinyscheme_genesi... 1633
tinyscheme_genesi... 1634 for (;;) {
tinyscheme_genesi... 1635 c=inchar(sc);
tinyscheme_genesi... 1636 if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
tinyscheme_genesi... 1637 return sc->F;
tinyscheme_genesi... 1638 }
tinyscheme_genesi... 1639 switch(state) {
tinyscheme_genesi... 1640 case st_ok:
tinyscheme_genesi... 1641 switch(c) {
tinyscheme_genesi... 1642 case '\\':
tinyscheme_genesi... 1643 state=st_bsl;
tinyscheme_genesi... 1644 break;
tinyscheme_genesi... 1645 case '"':
tinyscheme_genesi... 1646 *p=0;
tinyscheme_genesi... 1647 return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
tinyscheme_genesi... 1648 default:
tinyscheme_genesi... 1649 *p++=c;
tinyscheme_genesi... 1650 break;
tinyscheme_genesi... 1651 }
tinyscheme_genesi... 1652 break;
tinyscheme_genesi... 1653 case st_bsl:
tinyscheme_genesi... 1654 switch(c) {
tinyscheme_genesi... 1655 case '0':
tinyscheme_genesi... 1656 case '1':
tinyscheme_genesi... 1657 case '2':
tinyscheme_genesi... 1658 case '3':
tinyscheme_genesi... 1659 case '4':
tinyscheme_genesi... 1660 case '5':
tinyscheme_genesi... 1661 case '6':
tinyscheme_genesi... 1662 case '7':
tinyscheme_genesi... 1663 state=st_oct1;
tinyscheme_genesi... 1664 c1=c-'0';
tinyscheme_genesi... 1665 break;
tinyscheme_genesi... 1666 case 'x':
tinyscheme_genesi... 1667 case 'X':
tinyscheme_genesi... 1668 state=st_x1;
tinyscheme_genesi... 1669 c1=0;
tinyscheme_genesi... 1670 break;
tinyscheme_genesi... 1671 case 'n':
tinyscheme_genesi... 1672 *p++='\n';
tinyscheme_genesi... 1673 state=st_ok;
tinyscheme_genesi... 1674 break;
tinyscheme_genesi... 1675 case 't':
tinyscheme_genesi... 1676 *p++='\t';
tinyscheme_genesi... 1677 state=st_ok;
tinyscheme_genesi... 1678 break;
tinyscheme_genesi... 1679 case 'r':
tinyscheme_genesi... 1680 *p++='\r';
tinyscheme_genesi... 1681 state=st_ok;
tinyscheme_genesi... 1682 break;
tinyscheme_genesi... 1683 case '"':
tinyscheme_genesi... 1684 *p++='"';
tinyscheme_genesi... 1685 state=st_ok;
tinyscheme_genesi... 1686 break;
tinyscheme_genesi... 1687 default:
tinyscheme_genesi... 1688 *p++=c;
tinyscheme_genesi... 1689 state=st_ok;
tinyscheme_genesi... 1690 break;
tinyscheme_genesi... 1691 }
tinyscheme_genesi... 1692 break;
tinyscheme_genesi... 1693 case st_x1:
tinyscheme_genesi... 1694 case st_x2:
tinyscheme_genesi... 1695 c=toupper(c);
tinyscheme_genesi... 1696 if(c>='0' && c<='F') {
tinyscheme_genesi... 1697 if(c<='9') {
tinyscheme_genesi... 1698 c1=(c1<<4)+c-'0';
tinyscheme_genesi... 1699 } else {
tinyscheme_genesi... 1700 c1=(c1<<4)+c-'A'+10;
tinyscheme_genesi... 1701 }
tinyscheme_genesi... 1702 if(state==st_x1) {
tinyscheme_genesi... 1703 state=st_x2;
tinyscheme_genesi... 1704 } else {
tinyscheme_genesi... 1705 *p++=c1;
tinyscheme_genesi... 1706 state=st_ok;
tinyscheme_genesi... 1707 }
tinyscheme_genesi... 1708 } else {
tinyscheme_genesi... 1709 return sc->F;
tinyscheme_genesi... 1710 }
tinyscheme_genesi... 1711 break;
tinyscheme_genesi... 1712 case st_oct1:
tinyscheme_genesi... 1713 case st_oct2:
tinyscheme_genesi... 1714 if (c < '0' || c > '7')
tinyscheme_genesi... 1715 {
tinyscheme_genesi... 1716 *p++=c1;
tinyscheme_genesi... 1717 backchar(sc, c);
tinyscheme_genesi... 1718 state=st_ok;
tinyscheme_genesi... 1719 }
tinyscheme_genesi... 1720 else
tinyscheme_genesi... 1721 {
tinyscheme_genesi... 1722 if (state==st_oct2 && c1 >= 32)
tinyscheme_genesi... 1723 return sc->F;
tinyscheme_genesi... 1724
tinyscheme_genesi... 1725 c1=(c1<<3)+(c-'0');
tinyscheme_genesi... 1726
tinyscheme_genesi... 1727 if (state == st_oct1)
tinyscheme_genesi... 1728 state=st_oct2;
tinyscheme_genesi... 1729 else
tinyscheme_genesi... 1730 {
tinyscheme_genesi... 1731 *p++=c1;
tinyscheme_genesi... 1732 state=st_ok;
tinyscheme_genesi... 1733 }
tinyscheme_genesi... 1734 }
tinyscheme_genesi... 1735 break;
tinyscheme_genesi... 1736
tinyscheme_genesi... 1737 }
tinyscheme_genesi... 1738 }
tinyscheme_genesi... 1739 }
tinyscheme_genesi... 1740
tinyscheme_genesi... 1741
tinyscheme_genesi... 1742 static INLINE int is_one_of(char *s, int c) {
tinyscheme_genesi... 1743 if(c==EOF) return 1;
tinyscheme_genesi... 1744 while (*s)
tinyscheme_genesi... 1745 if (*s++ == c)
tinyscheme_genesi... 1746 return (1);
tinyscheme_genesi... 1747 return (0);
tinyscheme_genesi... 1748 }
tinyscheme_genesi... 1749
tinyscheme_genesi... 1750
tinyscheme_genesi... 1751 static INLINE int skipspace(scheme *sc) {
tinyscheme_genesi... 1752 int c = 0, curr_line = 0;
tinyscheme_genesi... 1753
tinyscheme_genesi... 1754 do {
tinyscheme_genesi... 1755 c=inchar(sc);
tinyscheme_genesi... 1756 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1757 if(c=='\n')
tinyscheme_genesi... 1758 curr_line++;
tinyscheme_genesi... 1759 #endif
tinyscheme_genesi... 1760 } while (isspace(c));
tinyscheme_genesi... 1761
tinyscheme_genesi... 1762
tinyscheme_genesi... 1763 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1764 if (sc->load_stack[sc->file_i].kind & port_file)
tinyscheme_genesi... 1765 sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
tinyscheme_genesi... 1766 #endif
tinyscheme_genesi... 1767
tinyscheme_genesi... 1768 if(c!=EOF) {
tinyscheme_genesi... 1769 backchar(sc,c);
tinyscheme_genesi... 1770 return 1;
tinyscheme_genesi... 1771 }
tinyscheme_genesi... 1772 else
tinyscheme_genesi... 1773 { return EOF; }
tinyscheme_genesi... 1774 }
tinyscheme_genesi... 1775
tinyscheme_genesi... 1776
tinyscheme_genesi... 1777 static int token(scheme *sc) {
tinyscheme_genesi... 1778 int c;
tinyscheme_genesi... 1779 c = skipspace(sc);
tinyscheme_genesi... 1780 if(c == EOF) { return (TOK_EOF); }
tinyscheme_genesi... 1781 switch (c=inchar(sc)) {
tinyscheme_genesi... 1782 case EOF:
tinyscheme_genesi... 1783 return (TOK_EOF);
tinyscheme_genesi... 1784 case '(':
tinyscheme_genesi... 1785 return (TOK_LPAREN);
tinyscheme_genesi... 1786 case ')':
tinyscheme_genesi... 1787 return (TOK_RPAREN);
tinyscheme_genesi... 1788 case '.':
tinyscheme_genesi... 1789 c=inchar(sc);
tinyscheme_genesi... 1790 if(is_one_of(" \n\t",c)) {
tinyscheme_genesi... 1791 return (TOK_DOT);
tinyscheme_genesi... 1792 } else {
tinyscheme_genesi... 1793 backchar(sc,c);
tinyscheme_genesi... 1794 backchar(sc,'.');
tinyscheme_genesi... 1795 return TOK_ATOM;
tinyscheme_genesi... 1796 }
tinyscheme_genesi... 1797 case '\'':
tinyscheme_genesi... 1798 return (TOK_QUOTE);
tinyscheme_genesi... 1799 case ';':
tinyscheme_genesi... 1800 while ((c=inchar(sc)) != '\n' && c!=EOF)
tinyscheme_genesi... 1801 ;
tinyscheme_genesi... 1802
tinyscheme_genesi... 1803 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1804 if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
tinyscheme_genesi... 1805 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
tinyscheme_genesi... 1806 #endif
tinyscheme_genesi... 1807
tinyscheme_genesi... 1808 if(c == EOF)
tinyscheme_genesi... 1809 { return (TOK_EOF); }
tinyscheme_genesi... 1810 else
tinyscheme_genesi... 1811 { return (token(sc));}
tinyscheme_genesi... 1812 case '"':
tinyscheme_genesi... 1813 return (TOK_DQUOTE);
tinyscheme_genesi... 1814 case BACKQUOTE:
tinyscheme_genesi... 1815 return (TOK_BQUOTE);
tinyscheme_genesi... 1816 case ',':
tinyscheme_genesi... 1817 if ((c=inchar(sc)) == '@') {
tinyscheme_genesi... 1818 return (TOK_ATMARK);
tinyscheme_genesi... 1819 } else {
tinyscheme_genesi... 1820 backchar(sc,c);
tinyscheme_genesi... 1821 return (TOK_COMMA);
tinyscheme_genesi... 1822 }
tinyscheme_genesi... 1823 case '#':
tinyscheme_genesi... 1824 c=inchar(sc);
tinyscheme_genesi... 1825 if (c == '(') {
tinyscheme_genesi... 1826 return (TOK_VEC);
tinyscheme_genesi... 1827 } else if(c == '!') {
tinyscheme_genesi... 1828 while ((c=inchar(sc)) != '\n' && c!=EOF)
tinyscheme_genesi... 1829 ;
tinyscheme_genesi... 1830
tinyscheme_genesi... 1831 #if SHOW_ERROR_LINE
tinyscheme_genesi... 1832 if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
tinyscheme_genesi... 1833 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
tinyscheme_genesi... 1834 #endif
tinyscheme_genesi... 1835
tinyscheme_genesi... 1836 if(c == EOF)
tinyscheme_genesi... 1837 { return (TOK_EOF); }
tinyscheme_genesi... 1838 else
tinyscheme_genesi... 1839 { return (token(sc));}
tinyscheme_genesi... 1840 } else {
tinyscheme_genesi... 1841 backchar(sc,c);
tinyscheme_genesi... 1842 if(is_one_of(" tfodxb\\",c)) {
tinyscheme_genesi... 1843 return TOK_SHARP_CONST;
tinyscheme_genesi... 1844 } else {
tinyscheme_genesi... 1845 return (TOK_SHARP);
tinyscheme_genesi... 1846 }
tinyscheme_genesi... 1847 }
tinyscheme_genesi... 1848 default:
tinyscheme_genesi... 1849 backchar(sc,c);
tinyscheme_genesi... 1850 return (TOK_ATOM);
tinyscheme_genesi... 1851 }
tinyscheme_genesi... 1852 }
tinyscheme_genesi... 1853
tinyscheme_genesi... 1854
tinyscheme_genesi... 1855 #define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
tinyscheme_genesi... 1856
tinyscheme_genesi... 1857 static void printslashstring(scheme *sc, char *p, int len) {
tinyscheme_genesi... 1858 int i;
tinyscheme_genesi... 1859 unsigned char *s=(unsigned char*)p;
tinyscheme_genesi... 1860 putcharacter(sc,'"');
tinyscheme_genesi... 1861 for ( i=0; i<len; i++) {
tinyscheme_genesi... 1862 if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
tinyscheme_genesi... 1863 putcharacter(sc,'\\');
tinyscheme_genesi... 1864 switch(*s) {
tinyscheme_genesi... 1865 case '"':
tinyscheme_genesi... 1866 putcharacter(sc,'"');
tinyscheme_genesi... 1867 break;
tinyscheme_genesi... 1868 case '\n':
tinyscheme_genesi... 1869 putcharacter(sc,'n');
tinyscheme_genesi... 1870 break;
tinyscheme_genesi... 1871 case '\t':
tinyscheme_genesi... 1872 putcharacter(sc,'t');
tinyscheme_genesi... 1873 break;
tinyscheme_genesi... 1874 case '\r':
tinyscheme_genesi... 1875 putcharacter(sc,'r');
tinyscheme_genesi... 1876 break;
tinyscheme_genesi... 1877 case '\\':
tinyscheme_genesi... 1878 putcharacter(sc,'\\');
tinyscheme_genesi... 1879 break;
tinyscheme_genesi... 1880 default: {
tinyscheme_genesi... 1881 int d=*s/16;
tinyscheme_genesi... 1882 putcharacter(sc,'x');
tinyscheme_genesi... 1883 if(d<10) {
tinyscheme_genesi... 1884 putcharacter(sc,d+'0');
tinyscheme_genesi... 1885 } else {
tinyscheme_genesi... 1886 putcharacter(sc,d-10+'A');
tinyscheme_genesi... 1887 }
tinyscheme_genesi... 1888 d=*s%16;
tinyscheme_genesi... 1889 if(d<10) {
tinyscheme_genesi... 1890 putcharacter(sc,d+'0');
tinyscheme_genesi... 1891 } else {
tinyscheme_genesi... 1892 putcharacter(sc,d-10+'A');
tinyscheme_genesi... 1893 }
tinyscheme_genesi... 1894 }
tinyscheme_genesi... 1895 }
tinyscheme_genesi... 1896 } else {
tinyscheme_genesi... 1897 putcharacter(sc,*s);
tinyscheme_genesi... 1898 }
tinyscheme_genesi... 1899 s++;
tinyscheme_genesi... 1900 }
tinyscheme_genesi... 1901 putcharacter(sc,'"');
tinyscheme_genesi... 1902 }
tinyscheme_genesi... 1903
tinyscheme_genesi... 1904
tinyscheme_genesi... 1905
tinyscheme_genesi... 1906 static void printatom(scheme *sc, pointer l, int f) {
tinyscheme_genesi... 1907 char *p;
tinyscheme_genesi... 1908 int len;
tinyscheme_genesi... 1909 atom2str(sc,l,f,&p,&len);
tinyscheme_genesi... 1910 putchars(sc,p,len);
tinyscheme_genesi... 1911 }
tinyscheme_genesi... 1912
tinyscheme_genesi... 1913
tinyscheme_genesi... 1914
tinyscheme_genesi... 1915 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
tinyscheme_genesi... 1916 char *p;
tinyscheme_genesi... 1917
tinyscheme_genesi... 1918 if (l == sc->NIL) {
tinyscheme_genesi... 1919 p = "()";
tinyscheme_genesi... 1920 } else if (l == sc->T) {
tinyscheme_genesi... 1921 p = "#t";
tinyscheme_genesi... 1922 } else if (l == sc->F) {
tinyscheme_genesi... 1923 p = "#f";
tinyscheme_genesi... 1924 } else if (l == sc->EOF_OBJ) {
tinyscheme_genesi... 1925 p = "#<EOF>";
tinyscheme_genesi... 1926 } else if (is_port(l)) {
tinyscheme_genesi... 1927 p = sc->strbuff;
tinyscheme_genesi... 1928 snprintf(p, STRBUFFSIZE, "#<PORT>");
tinyscheme_genesi... 1929 } else if (is_number(l)) {
tinyscheme_genesi... 1930 p = sc->strbuff;
tinyscheme_genesi... 1931 if (f <= 1 || f == 10) {
tinyscheme_genesi... 1932 if(num_is_integer(l)) {
tinyscheme_genesi... 1933 snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
tinyscheme_genesi... 1934 } else {
tinyscheme_genesi... 1935 snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
tinyscheme_genesi... 1936
tinyscheme_genesi... 1937 f = strcspn(p, ".e");
tinyscheme_genesi... 1938 if (p[f] == 0) {
tinyscheme_genesi... 1939 p[f] = '.';
tinyscheme_genesi... 1940 p[f+1] = '0';
tinyscheme_genesi... 1941 p[f+2] = 0;
tinyscheme_genesi... 1942 }
tinyscheme_genesi... 1943 }
tinyscheme_genesi... 1944 } else {
tinyscheme_genesi... 1945 long v = ivalue(l);
tinyscheme_genesi... 1946 if (f == 16) {
tinyscheme_genesi... 1947 if (v >= 0)
tinyscheme_genesi... 1948 snprintf(p, STRBUFFSIZE, "%lx", v);
tinyscheme_genesi... 1949 else
tinyscheme_genesi... 1950 snprintf(p, STRBUFFSIZE, "-%lx", -v);
tinyscheme_genesi... 1951 } else if (f == 8) {
tinyscheme_genesi... 1952 if (v >= 0)
tinyscheme_genesi... 1953 snprintf(p, STRBUFFSIZE, "%lo", v);
tinyscheme_genesi... 1954 else
tinyscheme_genesi... 1955 snprintf(p, STRBUFFSIZE, "-%lo", -v);
tinyscheme_genesi... 1956 } else if (f == 2) {
tinyscheme_genesi... 1957 unsigned long b = (v < 0) ? -v : v;
tinyscheme_genesi... 1958 p = &p[STRBUFFSIZE-1];
tinyscheme_genesi... 1959 *p = 0;
tinyscheme_genesi... 1960 do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
tinyscheme_genesi... 1961 if (v < 0) *--p = '-';
tinyscheme_genesi... 1962 }
tinyscheme_genesi... 1963 }
tinyscheme_genesi... 1964 } else if (is_string(l)) {
tinyscheme_genesi... 1965 if (!f) {
tinyscheme_genesi... 1966 p = strvalue(l);
tinyscheme_genesi... 1967 } else {
tinyscheme_genesi... 1968 *pp=sc->strbuff;
tinyscheme_genesi... 1969 *plen=0;
tinyscheme_genesi... 1970 printslashstring(sc, strvalue(l), strlength(l));
tinyscheme_genesi... 1971 return;
tinyscheme_genesi... 1972 }
tinyscheme_genesi... 1973 } else if (is_character(l)) {
tinyscheme_genesi... 1974 int c=charvalue(l);
tinyscheme_genesi... 1975 p = sc->strbuff;
tinyscheme_genesi... 1976 if (!f) {
tinyscheme_genesi... 1977 p[0]=c;
tinyscheme_genesi... 1978 p[1]=0;
tinyscheme_genesi... 1979 } else {
tinyscheme_genesi... 1980 switch(c) {
tinyscheme_genesi... 1981 case ' ':
tinyscheme_genesi... 1982 snprintf(p,STRBUFFSIZE,"#\\space"); break;
tinyscheme_genesi... 1983 case '\n':
tinyscheme_genesi... 1984 snprintf(p,STRBUFFSIZE,"#\\newline"); break;
tinyscheme_genesi... 1985 case '\r':
tinyscheme_genesi... 1986 snprintf(p,STRBUFFSIZE,"#\\return"); break;
tinyscheme_genesi... 1987 case '\t':
tinyscheme_genesi... 1988 snprintf(p,STRBUFFSIZE,"#\\tab"); break;
tinyscheme_genesi... 1989 default:
tinyscheme_genesi... 1990 #if USE_ASCII_NAMES
tinyscheme_genesi... 1991 if(c==127) {
tinyscheme_genesi... 1992 snprintf(p,STRBUFFSIZE, "#\\del");
tinyscheme_genesi... 1993 break;
tinyscheme_genesi... 1994 } else if(c<32) {
tinyscheme_genesi... 1995 snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]);
tinyscheme_genesi... 1996 break;
tinyscheme_genesi... 1997 }
tinyscheme_genesi... 1998 #else
tinyscheme_genesi... 1999 if(c<32) {
tinyscheme_genesi... 2000 snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
tinyscheme_genesi... 2001 break;
tinyscheme_genesi... 2002 }
tinyscheme_genesi... 2003 #endif
tinyscheme_genesi... 2004 snprintf(p,STRBUFFSIZE,"#\\%c",c); break;
tinyscheme_genesi... 2005 break;
tinyscheme_genesi... 2006 }
tinyscheme_genesi... 2007 }
tinyscheme_genesi... 2008 } else if (is_symbol(l)) {
tinyscheme_genesi... 2009 p = symname(l);
tinyscheme_genesi... 2010 } else if (is_proc(l)) {
tinyscheme_genesi... 2011 p = sc->strbuff;
tinyscheme_genesi... 2012 snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
tinyscheme_genesi... 2013 } else if (is_macro(l)) {
tinyscheme_genesi... 2014 p = "#<MACRO>";
tinyscheme_genesi... 2015 } else if (is_closure(l)) {
tinyscheme_genesi... 2016 p = "#<CLOSURE>";
tinyscheme_genesi... 2017 } else if (is_promise(l)) {
tinyscheme_genesi... 2018 p = "#<PROMISE>";
tinyscheme_genesi... 2019 } else if (is_foreign(l)) {
tinyscheme_genesi... 2020 p = sc->strbuff;
tinyscheme_genesi... 2021 snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
tinyscheme_genesi... 2022 } else if (is_continuation(l)) {
tinyscheme_genesi... 2023 p = "#<CONTINUATION>";
tinyscheme_genesi... 2024 } else {
tinyscheme_genesi... 2025 p = "#<ERROR>";
tinyscheme_genesi... 2026 }
tinyscheme_genesi... 2027 *pp=p;
tinyscheme_genesi... 2028 *plen=strlen(p);
tinyscheme_genesi... 2029 }
tinyscheme_genesi... 2030
tinyscheme_genesi... 2031
tinyscheme_genesi... 2032
tinyscheme_genesi... 2033 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
tinyscheme_genesi... 2034 pointer x = get_cell(sc, c, e);
tinyscheme_genesi... 2035
tinyscheme_genesi... 2036 typeflag(x) = T_CLOSURE;
tinyscheme_genesi... 2037 car(x) = c;
tinyscheme_genesi... 2038 cdr(x) = e;
tinyscheme_genesi... 2039 return (x);
tinyscheme_genesi... 2040 }
tinyscheme_genesi... 2041
tinyscheme_genesi... 2042
tinyscheme_genesi... 2043 static pointer mk_continuation(scheme *sc, pointer d) {
tinyscheme_genesi... 2044 pointer x = get_cell(sc, sc->NIL, d);
tinyscheme_genesi... 2045
tinyscheme_genesi... 2046 typeflag(x) = T_CONTINUATION;
tinyscheme_genesi... 2047 cont_dump(x) = d;
tinyscheme_genesi... 2048 return (x);
tinyscheme_genesi... 2049 }
tinyscheme_genesi... 2050
tinyscheme_genesi... 2051 static pointer list_star(scheme *sc, pointer d) {
tinyscheme_genesi... 2052 pointer p, q;
tinyscheme_genesi... 2053 if(cdr(d)==sc->NIL) {
tinyscheme_genesi... 2054 return car(d);
tinyscheme_genesi... 2055 }
tinyscheme_genesi... 2056 p=cons(sc,car(d),cdr(d));
tinyscheme_genesi... 2057 q=p;
tinyscheme_genesi... 2058 while(cdr(cdr(p))!=sc->NIL) {
tinyscheme_genesi... 2059 d=cons(sc,car(p),cdr(p));
tinyscheme_genesi... 2060 if(cdr(cdr(p))!=sc->NIL) {
tinyscheme_genesi... 2061 p=cdr(d);
tinyscheme_genesi... 2062 }
tinyscheme_genesi... 2063 }
tinyscheme_genesi... 2064 cdr(p)=car(cdr(p));
tinyscheme_genesi... 2065 return q;
tinyscheme_genesi... 2066 }
tinyscheme_genesi... 2067
tinyscheme_genesi... 2068
tinyscheme_genesi... 2069 static pointer reverse(scheme *sc, pointer a) {
tinyscheme_genesi... 2070
tinyscheme_genesi... 2071 pointer p = sc->NIL;
tinyscheme_genesi... 2072
tinyscheme_genesi... 2073 for ( ; is_pair(a); a = cdr(a)) {
tinyscheme_genesi... 2074 p = cons(sc, car(a), p);
tinyscheme_genesi... 2075 }
tinyscheme_genesi... 2076 return (p);
tinyscheme_genesi... 2077 }
tinyscheme_genesi... 2078
tinyscheme_genesi... 2079
tinyscheme_genesi... 2080 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
tinyscheme_genesi... 2081 pointer p = list, result = term, q;
tinyscheme_genesi... 2082
tinyscheme_genesi... 2083 while (p != sc->NIL) {
tinyscheme_genesi... 2084 q = cdr(p);
tinyscheme_genesi... 2085 cdr(p) = result;
tinyscheme_genesi... 2086 result = p;
tinyscheme_genesi... 2087 p = q;
tinyscheme_genesi... 2088 }
tinyscheme_genesi... 2089 return (result);
tinyscheme_genesi... 2090 }
tinyscheme_genesi... 2091
tinyscheme_genesi... 2092
tinyscheme_genesi... 2093 static pointer revappend(scheme *sc, pointer a, pointer b) {
tinyscheme_genesi... 2094 pointer result = a;
tinyscheme_genesi... 2095 pointer p = b;
tinyscheme_genesi... 2096
tinyscheme_genesi... 2097 while (is_pair(p)) {
tinyscheme_genesi... 2098 result = cons(sc, car(p), result);
tinyscheme_genesi... 2099 p = cdr(p);
tinyscheme_genesi... 2100 }
tinyscheme_genesi... 2101
tinyscheme_genesi... 2102 if (p == sc->NIL) {
tinyscheme_genesi... 2103 return result;
tinyscheme_genesi... 2104 }
tinyscheme_genesi... 2105
tinyscheme_genesi... 2106 return sc->F;
tinyscheme_genesi... 2107 }
tinyscheme_genesi... 2108
tinyscheme_genesi... 2109
tinyscheme_genesi... 2110 int eqv(pointer a, pointer b) {
tinyscheme_genesi... 2111 if (is_string(a)) {
tinyscheme_genesi... 2112 if (is_string(b))
tinyscheme_genesi... 2113 return (strvalue(a) == strvalue(b));
tinyscheme_genesi... 2114 else
tinyscheme_genesi... 2115 return (0);
tinyscheme_genesi... 2116 } else if (is_number(a)) {
tinyscheme_genesi... 2117 if (is_number(b)) {
tinyscheme_genesi... 2118 if (num_is_integer(a) == num_is_integer(b))
tinyscheme_genesi... 2119 return num_eq(nvalue(a),nvalue(b));
tinyscheme_genesi... 2120 }
tinyscheme_genesi... 2121 return (0);
tinyscheme_genesi... 2122 } else if (is_character(a)) {
tinyscheme_genesi... 2123 if (is_character(b))
tinyscheme_genesi... 2124 return charvalue(a)==charvalue(b);
tinyscheme_genesi... 2125 else
tinyscheme_genesi... 2126 return (0);
tinyscheme_genesi... 2127 } else if (is_port(a)) {
tinyscheme_genesi... 2128 if (is_port(b))
tinyscheme_genesi... 2129 return a==b;
tinyscheme_genesi... 2130 else
tinyscheme_genesi... 2131 return (0);
tinyscheme_genesi... 2132 } else if (is_proc(a)) {
tinyscheme_genesi... 2133 if (is_proc(b))
tinyscheme_genesi... 2134 return procnum(a)==procnum(b);
tinyscheme_genesi... 2135 else
tinyscheme_genesi... 2136 return (0);
tinyscheme_genesi... 2137 } else {
tinyscheme_genesi... 2138 return (a == b);
tinyscheme_genesi... 2139 }
tinyscheme_genesi... 2140 }
tinyscheme_genesi... 2141
tinyscheme_genesi... 2142
tinyscheme_genesi... 2143
tinyscheme_genesi... 2144 #define is_true(p) ((p) != sc->F)
tinyscheme_genesi... 2145 #define is_false(p) ((p) == sc->F)
tinyscheme_genesi... 2146
tinyscheme_genesi... 2147
tinyscheme_genesi... 2148
tinyscheme_genesi... 2149 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
tinyscheme_genesi... 2150
tinyscheme_genesi... 2151 static int hash_fn(const char *key, int table_size)
tinyscheme_genesi... 2152 {
tinyscheme_genesi... 2153 unsigned int hashed = 0;
tinyscheme_genesi... 2154 const char *c;
tinyscheme_genesi... 2155 int bits_per_int = sizeof(unsigned int)*8;
tinyscheme_genesi... 2156
tinyscheme_genesi... 2157 for (c = key; *c; c++) {
tinyscheme_genesi... 2158
tinyscheme_genesi... 2159 hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
tinyscheme_genesi... 2160 hashed ^= *c;
tinyscheme_genesi... 2161 }
tinyscheme_genesi... 2162 return hashed % table_size;
tinyscheme_genesi... 2163 }
tinyscheme_genesi... 2164 #endif
tinyscheme_genesi... 2165
tinyscheme_genesi... 2166 #ifndef USE_ALIST_ENV
tinyscheme_genesi... 2167
tinyscheme_genesi... 2168
tinyscheme_genesi... 2169 * In this implementation, each frame of the environment may be
tinyscheme_genesi... 2170 * a hash table: a vector of alists hashed by variable name.
tinyscheme_genesi... 2171 * In practice, we use a vector only for the initial frame;
tinyscheme_genesi... 2172 * subsequent frames are too small and transient for the lookup
tinyscheme_genesi... 2173 * speed to out-weigh the cost of making a new vector.
tinyscheme_genesi... 2174 */
tinyscheme_genesi... 2175
tinyscheme_genesi... 2176 static void new_frame_in_env(scheme *sc, pointer old_env)
tinyscheme_genesi... 2177 {
tinyscheme_genesi... 2178 pointer new_frame;
tinyscheme_genesi... 2179
tinyscheme_genesi... 2180
tinyscheme_genesi... 2181 if (old_env == sc->NIL) {
tinyscheme_genesi... 2182 new_frame = mk_vector(sc, 461);
tinyscheme_genesi... 2183 } else {
tinyscheme_genesi... 2184 new_frame = sc->NIL;
tinyscheme_genesi... 2185 }
tinyscheme_genesi... 2186
tinyscheme_genesi... 2187 sc->envir = immutable_cons(sc, new_frame, old_env);
tinyscheme_genesi... 2188 setenvironment(sc->envir);
tinyscheme_genesi... 2189 }
tinyscheme_genesi... 2190
tinyscheme_genesi... 2191 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
tinyscheme_genesi... 2192 pointer variable, pointer value)
tinyscheme_genesi... 2193 {
tinyscheme_genesi... 2194 pointer slot = immutable_cons(sc, variable, value);
tinyscheme_genesi... 2195
tinyscheme_genesi... 2196 if (is_vector(car(env))) {
tinyscheme_genesi... 2197 int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
tinyscheme_genesi... 2198
tinyscheme_genesi... 2199 set_vector_elem(car(env), location,
tinyscheme_genesi... 2200 immutable_cons(sc, slot, vector_elem(car(env), location)));
tinyscheme_genesi... 2201 } else {
tinyscheme_genesi... 2202 car(env) = immutable_cons(sc, slot, car(env));
tinyscheme_genesi... 2203 }
tinyscheme_genesi... 2204 }
tinyscheme_genesi... 2205
tinyscheme_genesi... 2206 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
tinyscheme_genesi... 2207 {
tinyscheme_genesi... 2208 pointer x,y;
tinyscheme_genesi... 2209 int location;
tinyscheme_genesi... 2210
tinyscheme_genesi... 2211 for (x = env; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 2212 if (is_vector(car(x))) {
tinyscheme_genesi... 2213 location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
tinyscheme_genesi... 2214 y = vector_elem(car(x), location);
tinyscheme_genesi... 2215 } else {
tinyscheme_genesi... 2216 y = car(x);
tinyscheme_genesi... 2217 }
tinyscheme_genesi... 2218 for ( ; y != sc->NIL; y = cdr(y)) {
tinyscheme_genesi... 2219 if (caar(y) == hdl) {
tinyscheme_genesi... 2220 break;
tinyscheme_genesi... 2221 }
tinyscheme_genesi... 2222 }
tinyscheme_genesi... 2223 if (y != sc->NIL) {
tinyscheme_genesi... 2224 break;
tinyscheme_genesi... 2225 }
tinyscheme_genesi... 2226 if(!all) {
tinyscheme_genesi... 2227 return sc->NIL;
tinyscheme_genesi... 2228 }
tinyscheme_genesi... 2229 }
tinyscheme_genesi... 2230 if (x != sc->NIL) {
tinyscheme_genesi... 2231 return car(y);
tinyscheme_genesi... 2232 }
tinyscheme_genesi... 2233 return sc->NIL;
tinyscheme_genesi... 2234 }
tinyscheme_genesi... 2235
tinyscheme_genesi... 2236 #else /* USE_ALIST_ENV */
tinyscheme_genesi... 2237
tinyscheme_genesi... 2238 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
tinyscheme_genesi... 2239 {
tinyscheme_genesi... 2240 sc->envir = immutable_cons(sc, sc->NIL, old_env);
tinyscheme_genesi... 2241 setenvironment(sc->envir);
tinyscheme_genesi... 2242 }
tinyscheme_genesi... 2243
tinyscheme_genesi... 2244 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
tinyscheme_genesi... 2245 pointer variable, pointer value)
tinyscheme_genesi... 2246 {
tinyscheme_genesi... 2247 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
tinyscheme_genesi... 2248 }
tinyscheme_genesi... 2249
tinyscheme_genesi... 2250 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
tinyscheme_genesi... 2251 {
tinyscheme_genesi... 2252 pointer x,y;
tinyscheme_genesi... 2253 for (x = env; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 2254 for (y = car(x); y != sc->NIL; y = cdr(y)) {
tinyscheme_genesi... 2255 if (caar(y) == hdl) {
tinyscheme_genesi... 2256 break;
tinyscheme_genesi... 2257 }
tinyscheme_genesi... 2258 }
tinyscheme_genesi... 2259 if (y != sc->NIL) {
tinyscheme_genesi... 2260 break;
tinyscheme_genesi... 2261 }
tinyscheme_genesi... 2262 if(!all) {
tinyscheme_genesi... 2263 return sc->NIL;
tinyscheme_genesi... 2264 }
tinyscheme_genesi... 2265 }
tinyscheme_genesi... 2266 if (x != sc->NIL) {
tinyscheme_genesi... 2267 return car(y);
tinyscheme_genesi... 2268 }
tinyscheme_genesi... 2269 return sc->NIL;
tinyscheme_genesi... 2270 }
tinyscheme_genesi... 2271
tinyscheme_genesi... 2272 #endif /* USE_ALIST_ENV else */
tinyscheme_genesi... 2273
tinyscheme_genesi... 2274 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
tinyscheme_genesi... 2275 {
tinyscheme_genesi... 2276 new_slot_spec_in_env(sc, sc->envir, variable, value);
tinyscheme_genesi... 2277 }
tinyscheme_genesi... 2278
tinyscheme_genesi... 2279 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
tinyscheme_genesi... 2280 {
tinyscheme_genesi... 2281 cdr(slot) = value;
tinyscheme_genesi... 2282 }
tinyscheme_genesi... 2283
tinyscheme_genesi... 2284 static INLINE pointer slot_value_in_env(pointer slot)
tinyscheme_genesi... 2285 {
tinyscheme_genesi... 2286 return cdr(slot);
tinyscheme_genesi... 2287 }
tinyscheme_genesi... 2288
tinyscheme_genesi... 2289
tinyscheme_genesi... 2290
tinyscheme_genesi... 2291
tinyscheme_genesi... 2292 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
tinyscheme_genesi... 2293 const char *str = s;
tinyscheme_genesi... 2294 #if USE_ERROR_HOOK
tinyscheme_genesi... 2295 pointer x;
tinyscheme_genesi... 2296 pointer hdl=sc->ERROR_HOOK;
tinyscheme_genesi... 2297 #endif
tinyscheme_genesi... 2298
tinyscheme_genesi... 2299 #if SHOW_ERROR_LINE
tinyscheme_genesi... 2300 char sbuf[STRBUFFSIZE];
tinyscheme_genesi... 2301
tinyscheme_genesi... 2302
tinyscheme_genesi... 2303 if (sc->load_stack[sc->file_i].kind & port_file &&
tinyscheme_genesi... 2304 sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
tinyscheme_genesi... 2305 int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
tinyscheme_genesi... 2306 const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
tinyscheme_genesi... 2307
tinyscheme_genesi... 2308
tinyscheme_genesi... 2309 if(!fname) fname = "<unknown>";
tinyscheme_genesi... 2310
tinyscheme_genesi... 2311
tinyscheme_genesi... 2312 ln++;
tinyscheme_genesi... 2313 snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
tinyscheme_genesi... 2314
tinyscheme_genesi... 2315 str = (const char*)sbuf;
tinyscheme_genesi... 2316 }
tinyscheme_genesi... 2317 #endif
tinyscheme_genesi... 2318
tinyscheme_genesi... 2319 #if USE_ERROR_HOOK
tinyscheme_genesi... 2320 x=find_slot_in_env(sc,sc->envir,hdl,1);
tinyscheme_genesi... 2321 if (x != sc->NIL) {
tinyscheme_genesi... 2322 if(a!=0) {
tinyscheme_genesi... 2323 sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
tinyscheme_genesi... 2324 } else {
tinyscheme_genesi... 2325 sc->code = sc->NIL;
tinyscheme_genesi... 2326 }
tinyscheme_genesi... 2327 sc->code = cons(sc, mk_string(sc, str), sc->code);
tinyscheme_genesi... 2328 setimmutable(car(sc->code));
tinyscheme_genesi... 2329 sc->code = cons(sc, slot_value_in_env(x), sc->code);
tinyscheme_genesi... 2330 sc->op = (int)OP_EVAL;
tinyscheme_genesi... 2331 return sc->T;
tinyscheme_genesi... 2332 }
tinyscheme_genesi... 2333 #endif
tinyscheme_genesi... 2334
tinyscheme_genesi... 2335 if(a!=0) {
tinyscheme_genesi... 2336 sc->args = cons(sc, (a), sc->NIL);
tinyscheme_genesi... 2337 } else {
tinyscheme_genesi... 2338 sc->args = sc->NIL;
tinyscheme_genesi... 2339 }
tinyscheme_genesi... 2340 sc->args = cons(sc, mk_string(sc, str), sc->args);
tinyscheme_genesi... 2341 setimmutable(car(sc->args));
tinyscheme_genesi... 2342 sc->op = (int)OP_ERR0;
tinyscheme_genesi... 2343 return sc->T;
tinyscheme_genesi... 2344 }
tinyscheme_genesi... 2345 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
tinyscheme_genesi... 2346 #define Error_0(sc,s) return _Error_1(sc,s,0)
tinyscheme_genesi... 2347
tinyscheme_genesi... 2348
tinyscheme_genesi... 2349 # define BEGIN do {
tinyscheme_genesi... 2350 # define END } while (0)
tinyscheme_genesi... 2351 #define s_goto(sc,a) BEGIN \
tinyscheme_genesi... 2352 sc->op = (int)(a); \
tinyscheme_genesi... 2353 return sc->T; END
tinyscheme_genesi... 2354
tinyscheme_genesi... 2355 #define s_return(sc,a) return _s_return(sc,a)
tinyscheme_genesi... 2356
tinyscheme_genesi... 2357 #ifndef USE_SCHEME_STACK
tinyscheme_genesi... 2358
tinyscheme_genesi... 2359
tinyscheme_genesi... 2360 struct dump_stack_frame {
tinyscheme_genesi... 2361 enum scheme_opcodes op;
tinyscheme_genesi... 2362 pointer args;
tinyscheme_genesi... 2363 pointer envir;
tinyscheme_genesi... 2364 pointer code;
tinyscheme_genesi... 2365 };
tinyscheme_genesi... 2366
tinyscheme_genesi... 2367 #define STACK_GROWTH 3
tinyscheme_genesi... 2368
tinyscheme_genesi... 2369 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
tinyscheme_genesi... 2370 {
tinyscheme_genesi... 2371 int nframes = (int)sc->dump;
tinyscheme_genesi... 2372 struct dump_stack_frame *next_frame;
tinyscheme_genesi... 2373
tinyscheme_genesi... 2374
tinyscheme_genesi... 2375 if (nframes >= sc->dump_size) {
tinyscheme_genesi... 2376 sc->dump_size += STACK_GROWTH;
tinyscheme_genesi... 2377
tinyscheme_genesi... 2378 sc->dump_base = realloc(sc->dump_base,
tinyscheme_genesi... 2379 sizeof(struct dump_stack_frame) * sc->dump_size);
tinyscheme_genesi... 2380 }
tinyscheme_genesi... 2381 next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
tinyscheme_genesi... 2382 next_frame->op = op;
tinyscheme_genesi... 2383 next_frame->args = args;
tinyscheme_genesi... 2384 next_frame->envir = sc->envir;
tinyscheme_genesi... 2385 next_frame->code = code;
tinyscheme_genesi... 2386 sc->dump = (pointer)(nframes+1);
tinyscheme_genesi... 2387 }
tinyscheme_genesi... 2388
tinyscheme_genesi... 2389 static pointer _s_return(scheme *sc, pointer a)
tinyscheme_genesi... 2390 {
tinyscheme_genesi... 2391 int nframes = (int)sc->dump;
tinyscheme_genesi... 2392 struct dump_stack_frame *frame;
tinyscheme_genesi... 2393
tinyscheme_genesi... 2394 sc->value = (a);
tinyscheme_genesi... 2395 if (nframes <= 0) {
tinyscheme_genesi... 2396 return sc->NIL;
tinyscheme_genesi... 2397 }
tinyscheme_genesi... 2398 nframes--;
tinyscheme_genesi... 2399 frame = (struct dump_stack_frame *)sc->dump_base + nframes;
tinyscheme_genesi... 2400 sc->op = frame->op;
tinyscheme_genesi... 2401 sc->args = frame->args;
tinyscheme_genesi... 2402 sc->envir = frame->envir;
tinyscheme_genesi... 2403 sc->code = frame->code;
tinyscheme_genesi... 2404 sc->dump = (pointer)nframes;
tinyscheme_genesi... 2405 return sc->T;
tinyscheme_genesi... 2406 }
tinyscheme_genesi... 2407
tinyscheme_genesi... 2408 static INLINE void dump_stack_reset(scheme *sc)
tinyscheme_genesi... 2409 {
tinyscheme_genesi... 2410
tinyscheme_genesi... 2411 sc->dump = (pointer)0;
tinyscheme_genesi... 2412 }
tinyscheme_genesi... 2413
tinyscheme_genesi... 2414 static INLINE void dump_stack_initialize(scheme *sc)
tinyscheme_genesi... 2415 {
tinyscheme_genesi... 2416 sc->dump_size = 0;
tinyscheme_genesi... 2417 sc->dump_base = NULL;
tinyscheme_genesi... 2418 dump_stack_reset(sc);
tinyscheme_genesi... 2419 }
tinyscheme_genesi... 2420
tinyscheme_genesi... 2421 static void dump_stack_free(scheme *sc)
tinyscheme_genesi... 2422 {
tinyscheme_genesi... 2423 free(sc->dump_base);
tinyscheme_genesi... 2424 sc->dump_base = NULL;
tinyscheme_genesi... 2425 sc->dump = (pointer)0;
tinyscheme_genesi... 2426 sc->dump_size = 0;
tinyscheme_genesi... 2427 }
tinyscheme_genesi... 2428
tinyscheme_genesi... 2429 static INLINE void dump_stack_mark(scheme *sc)
tinyscheme_genesi... 2430 {
tinyscheme_genesi... 2431 int nframes = (int)sc->dump;
tinyscheme_genesi... 2432 int i;
tinyscheme_genesi... 2433 for(i=0; i<nframes; i++) {
tinyscheme_genesi... 2434 struct dump_stack_frame *frame;
tinyscheme_genesi... 2435 frame = (struct dump_stack_frame *)sc->dump_base + i;
tinyscheme_genesi... 2436 mark(frame->args);
tinyscheme_genesi... 2437 mark(frame->envir);
tinyscheme_genesi... 2438 mark(frame->code);
tinyscheme_genesi... 2439 }
tinyscheme_genesi... 2440 }
tinyscheme_genesi... 2441
tinyscheme_genesi... 2442 #else
tinyscheme_genesi... 2443
tinyscheme_genesi... 2444 static INLINE void dump_stack_reset(scheme *sc)
tinyscheme_genesi... 2445 {
tinyscheme_genesi... 2446 sc->dump = sc->NIL;
tinyscheme_genesi... 2447 }
tinyscheme_genesi... 2448
tinyscheme_genesi... 2449 static INLINE void dump_stack_initialize(scheme *sc)
tinyscheme_genesi... 2450 {
tinyscheme_genesi... 2451 dump_stack_reset(sc);
tinyscheme_genesi... 2452 }
tinyscheme_genesi... 2453
tinyscheme_genesi... 2454 static void dump_stack_free(scheme *sc)
tinyscheme_genesi... 2455 {
tinyscheme_genesi... 2456 sc->dump = sc->NIL;
tinyscheme_genesi... 2457 }
tinyscheme_genesi... 2458
tinyscheme_genesi... 2459 static pointer _s_return(scheme *sc, pointer a) {
tinyscheme_genesi... 2460 sc->value = (a);
tinyscheme_genesi... 2461 if(sc->dump==sc->NIL) return sc->NIL;
tinyscheme_genesi... 2462 sc->op = ivalue(car(sc->dump));
tinyscheme_genesi... 2463 sc->args = cadr(sc->dump);
tinyscheme_genesi... 2464 sc->envir = caddr(sc->dump);
tinyscheme_genesi... 2465 sc->code = cadddr(sc->dump);
tinyscheme_genesi... 2466 sc->dump = cddddr(sc->dump);
tinyscheme_genesi... 2467 return sc->T;
tinyscheme_genesi... 2468 }
tinyscheme_genesi... 2469
tinyscheme_genesi... 2470 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
tinyscheme_genesi... 2471 sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
tinyscheme_genesi... 2472 sc->dump = cons(sc, (args), sc->dump);
tinyscheme_genesi... 2473 sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
tinyscheme_genesi... 2474 }
tinyscheme_genesi... 2475
tinyscheme_genesi... 2476 static INLINE void dump_stack_mark(scheme *sc)
tinyscheme_genesi... 2477 {
tinyscheme_genesi... 2478 mark(sc->dump);
tinyscheme_genesi... 2479 }
tinyscheme_genesi... 2480 #endif
tinyscheme_genesi... 2481
tinyscheme_genesi... 2482 #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
tinyscheme_genesi... 2483
tinyscheme_genesi... 2484 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 2485 pointer x, y;
tinyscheme_genesi... 2486
tinyscheme_genesi... 2487 switch (op) {
tinyscheme_genesi... 2488 case OP_LOAD:
tinyscheme_genesi... 2489 if(file_interactive(sc)) {
tinyscheme_genesi... 2490 fprintf(sc->outport->_object._port->rep.stdio.file,
tinyscheme_genesi... 2491 "Loading %s\n", strvalue(car(sc->args)));
tinyscheme_genesi... 2492 }
tinyscheme_genesi... 2493 if (!file_push(sc,strvalue(car(sc->args)))) {
tinyscheme_genesi... 2494 Error_1(sc,"unable to open", car(sc->args));
tinyscheme_genesi... 2495 }
tinyscheme_genesi... 2496 else
tinyscheme_genesi... 2497 {
tinyscheme_genesi... 2498 sc->args = mk_integer(sc,sc->file_i);
tinyscheme_genesi... 2499 s_goto(sc,OP_T0LVL);
tinyscheme_genesi... 2500 }
tinyscheme_genesi... 2501
tinyscheme_genesi... 2502 case OP_T0LVL:
tinyscheme_genesi... 2503
tinyscheme_genesi... 2504 if(sc->loadport->_object._port->kind & port_saw_EOF)
tinyscheme_genesi... 2505 {
tinyscheme_genesi... 2506 if(sc->file_i == 0)
tinyscheme_genesi... 2507 {
tinyscheme_genesi... 2508 sc->args=sc->NIL;
tinyscheme_genesi... 2509 s_goto(sc,OP_QUIT);
tinyscheme_genesi... 2510 }
tinyscheme_genesi... 2511 else
tinyscheme_genesi... 2512 {
tinyscheme_genesi... 2513 file_pop(sc);
tinyscheme_genesi... 2514 s_return(sc,sc->value);
tinyscheme_genesi... 2515 }
tinyscheme_genesi... 2516
tinyscheme_genesi... 2517 }
tinyscheme_genesi... 2518
tinyscheme_genesi... 2519
tinyscheme_genesi... 2520 if(file_interactive(sc))
tinyscheme_genesi... 2521 {
tinyscheme_genesi... 2522 sc->envir = sc->global_env;
tinyscheme_genesi... 2523 dump_stack_reset(sc);
tinyscheme_genesi... 2524 putstr(sc,"\n");
tinyscheme_genesi... 2525 putstr(sc,prompt);
tinyscheme_genesi... 2526 }
tinyscheme_genesi... 2527
tinyscheme_genesi... 2528
tinyscheme_genesi... 2529 sc->nesting=0;
tinyscheme_genesi... 2530 sc->save_inport=sc->inport;
tinyscheme_genesi... 2531 sc->inport = sc->loadport;
tinyscheme_genesi... 2532 s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
tinyscheme_genesi... 2533 s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
tinyscheme_genesi... 2534 s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
tinyscheme_genesi... 2535 s_goto(sc,OP_READ_INTERNAL);
tinyscheme_genesi... 2536
tinyscheme_genesi... 2537 case OP_T1LVL:
tinyscheme_genesi... 2538 sc->code = sc->value;
tinyscheme_genesi... 2539 sc->inport=sc->save_inport;
tinyscheme_genesi... 2540 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2541
tinyscheme_genesi... 2542 case OP_READ_INTERNAL:
tinyscheme_genesi... 2543 sc->tok = token(sc);
tinyscheme_genesi... 2544 if(sc->tok==TOK_EOF)
tinyscheme_genesi... 2545 { s_return(sc,sc->EOF_OBJ); }
tinyscheme_genesi... 2546 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 2547
tinyscheme_genesi... 2548 case OP_GENSYM:
tinyscheme_genesi... 2549 s_return(sc, gensym(sc));
tinyscheme_genesi... 2550
tinyscheme_genesi... 2551 case OP_VALUEPRINT:
tinyscheme_genesi... 2552
tinyscheme_genesi... 2553 non-interactive to interactive mode, it needs to be
tinyscheme_genesi... 2554 already on the stack */
tinyscheme_genesi... 2555 if(sc->tracing) {
tinyscheme_genesi... 2556 putstr(sc,"\nGives: ");
tinyscheme_genesi... 2557 }
tinyscheme_genesi... 2558 if(file_interactive(sc)) {
tinyscheme_genesi... 2559 sc->print_flag = 1;
tinyscheme_genesi... 2560 sc->args = sc->value;
tinyscheme_genesi... 2561 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 2562 } else {
tinyscheme_genesi... 2563 s_return(sc,sc->value);
tinyscheme_genesi... 2564 }
tinyscheme_genesi... 2565
tinyscheme_genesi... 2566 case OP_EVAL:
tinyscheme_genesi... 2567 #if USE_TRACING
tinyscheme_genesi... 2568 if(sc->tracing) {
tinyscheme_genesi... 2569
tinyscheme_genesi... 2570 s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
tinyscheme_genesi... 2571 sc->args=sc->code;
tinyscheme_genesi... 2572 putstr(sc,"\nEval: ");
tinyscheme_genesi... 2573 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 2574 }
tinyscheme_genesi... 2575
tinyscheme_genesi... 2576 case OP_REAL_EVAL:
tinyscheme_genesi... 2577 #endif
tinyscheme_genesi... 2578 if (is_symbol(sc->code)) {
tinyscheme_genesi... 2579 x=find_slot_in_env(sc,sc->envir,sc->code,1);
tinyscheme_genesi... 2580 if (x != sc->NIL) {
tinyscheme_genesi... 2581 s_return(sc,slot_value_in_env(x));
tinyscheme_genesi... 2582 } else {
tinyscheme_genesi... 2583 Error_1(sc,"eval: unbound variable:", sc->code);
tinyscheme_genesi... 2584 }
tinyscheme_genesi... 2585 } else if (is_pair(sc->code)) {
tinyscheme_genesi... 2586 if (is_syntax(x = car(sc->code))) {
tinyscheme_genesi... 2587 sc->code = cdr(sc->code);
tinyscheme_genesi... 2588 s_goto(sc,syntaxnum(x));
tinyscheme_genesi... 2589 } else {
tinyscheme_genesi... 2590 s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
tinyscheme_genesi... 2591
tinyscheme_genesi... 2592 sc->code = car(sc->code);
tinyscheme_genesi... 2593 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2594 }
tinyscheme_genesi... 2595 } else {
tinyscheme_genesi... 2596 s_return(sc,sc->code);
tinyscheme_genesi... 2597 }
tinyscheme_genesi... 2598
tinyscheme_genesi... 2599 case OP_E0ARGS:
tinyscheme_genesi... 2600 if (is_macro(sc->value)) {
tinyscheme_genesi... 2601 s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
tinyscheme_genesi... 2602 sc->args = cons(sc,sc->code, sc->NIL);
tinyscheme_genesi... 2603 sc->code = sc->value;
tinyscheme_genesi... 2604 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 2605 } else {
tinyscheme_genesi... 2606 sc->code = cdr(sc->code);
tinyscheme_genesi... 2607 s_goto(sc,OP_E1ARGS);
tinyscheme_genesi... 2608 }
tinyscheme_genesi... 2609
tinyscheme_genesi... 2610 case OP_E1ARGS:
tinyscheme_genesi... 2611 sc->args = cons(sc, sc->value, sc->args);
tinyscheme_genesi... 2612 if (is_pair(sc->code)) {
tinyscheme_genesi... 2613 s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
tinyscheme_genesi... 2614 sc->code = car(sc->code);
tinyscheme_genesi... 2615 sc->args = sc->NIL;
tinyscheme_genesi... 2616 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2617 } else {
tinyscheme_genesi... 2618 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
tinyscheme_genesi... 2619 sc->code = car(sc->args);
tinyscheme_genesi... 2620 sc->args = cdr(sc->args);
tinyscheme_genesi... 2621 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 2622 }
tinyscheme_genesi... 2623
tinyscheme_genesi... 2624 #if USE_TRACING
tinyscheme_genesi... 2625 case OP_TRACING: {
tinyscheme_genesi... 2626 int tr=sc->tracing;
tinyscheme_genesi... 2627 sc->tracing=ivalue(car(sc->args));
tinyscheme_genesi... 2628 s_return(sc,mk_integer(sc,tr));
tinyscheme_genesi... 2629 }
tinyscheme_genesi... 2630 #endif
tinyscheme_genesi... 2631
tinyscheme_genesi... 2632 case OP_APPLY:
tinyscheme_genesi... 2633 #if USE_TRACING
tinyscheme_genesi... 2634 if(sc->tracing) {
tinyscheme_genesi... 2635 s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
tinyscheme_genesi... 2636 sc->print_flag = 1;
tinyscheme_genesi... 2637
tinyscheme_genesi... 2638 putstr(sc,"\nApply to: ");
tinyscheme_genesi... 2639 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 2640 }
tinyscheme_genesi... 2641
tinyscheme_genesi... 2642 case OP_REAL_APPLY:
tinyscheme_genesi... 2643 #endif
tinyscheme_genesi... 2644 if (is_proc(sc->code)) {
tinyscheme_genesi... 2645 s_goto(sc,procnum(sc->code));
tinyscheme_genesi... 2646 } else if (is_foreign(sc->code))
tinyscheme_genesi... 2647 {
tinyscheme_genesi... 2648
tinyscheme_genesi... 2649 push_recent_alloc(sc,sc->args,sc->NIL);
tinyscheme_genesi... 2650 x=sc->code->_object._ff(sc,sc->args);
tinyscheme_genesi... 2651 s_return(sc,x);
tinyscheme_genesi... 2652 } else if (is_closure(sc->code) || is_macro(sc->code)
tinyscheme_genesi... 2653 || is_promise(sc->code)) {
tinyscheme_genesi... 2654
tinyscheme_genesi... 2655
tinyscheme_genesi... 2656 new_frame_in_env(sc, closure_env(sc->code));
tinyscheme_genesi... 2657 for (x = car(closure_code(sc->code)), y = sc->args;
tinyscheme_genesi... 2658 is_pair(x); x = cdr(x), y = cdr(y)) {
tinyscheme_genesi... 2659 if (y == sc->NIL) {
tinyscheme_genesi... 2660 Error_0(sc,"not enough arguments");
tinyscheme_genesi... 2661 } else {
tinyscheme_genesi... 2662 new_slot_in_env(sc, car(x), car(y));
tinyscheme_genesi... 2663 }
tinyscheme_genesi... 2664 }
tinyscheme_genesi... 2665 if (x == sc->NIL) {
tinyscheme_genesi... 2666
tinyscheme_genesi... 2667 * if (y != sc->NIL) {
tinyscheme_genesi... 2668 * Error_0(sc,"too many arguments");
tinyscheme_genesi... 2669 * }
tinyscheme_genesi... 2670 */
tinyscheme_genesi... 2671 } else if (is_symbol(x))
tinyscheme_genesi... 2672 new_slot_in_env(sc, x, y);
tinyscheme_genesi... 2673 else {
tinyscheme_genesi... 2674 Error_1(sc,"syntax error in closure: not a symbol:", x);
tinyscheme_genesi... 2675 }
tinyscheme_genesi... 2676 sc->code = cdr(closure_code(sc->code));
tinyscheme_genesi... 2677 sc->args = sc->NIL;
tinyscheme_genesi... 2678 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2679 } else if (is_continuation(sc->code)) {
tinyscheme_genesi... 2680 sc->dump = cont_dump(sc->code);
tinyscheme_genesi... 2681 s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
tinyscheme_genesi... 2682 } else {
tinyscheme_genesi... 2683 Error_0(sc,"illegal function");
tinyscheme_genesi... 2684 }
tinyscheme_genesi... 2685
tinyscheme_genesi... 2686 case OP_DOMACRO:
tinyscheme_genesi... 2687 sc->code = sc->value;
tinyscheme_genesi... 2688 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2689
tinyscheme_genesi... 2690 #if 1
tinyscheme_genesi... 2691 case OP_LAMBDA:
tinyscheme_genesi... 2692
tinyscheme_genesi... 2693 set sc->value fall thru */
tinyscheme_genesi... 2694 {
tinyscheme_genesi... 2695 pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
tinyscheme_genesi... 2696 if(f==sc->NIL) {
tinyscheme_genesi... 2697 sc->value = sc->code;
tinyscheme_genesi... 2698
tinyscheme_genesi... 2699 } else {
tinyscheme_genesi... 2700 s_save(sc,OP_LAMBDA1,sc->args,sc->code);
tinyscheme_genesi... 2701 sc->args=cons(sc,sc->code,sc->NIL);
tinyscheme_genesi... 2702 sc->code=slot_value_in_env(f);
tinyscheme_genesi... 2703 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 2704 }
tinyscheme_genesi... 2705 }
tinyscheme_genesi... 2706
tinyscheme_genesi... 2707 case OP_LAMBDA1:
tinyscheme_genesi... 2708 s_return(sc,mk_closure(sc, sc->value, sc->envir));
tinyscheme_genesi... 2709
tinyscheme_genesi... 2710 #else
tinyscheme_genesi... 2711 case OP_LAMBDA:
tinyscheme_genesi... 2712 s_return(sc,mk_closure(sc, sc->code, sc->envir));
tinyscheme_genesi... 2713
tinyscheme_genesi... 2714 #endif
tinyscheme_genesi... 2715
tinyscheme_genesi... 2716 case OP_MKCLOSURE:
tinyscheme_genesi... 2717 x=car(sc->args);
tinyscheme_genesi... 2718 if(car(x)==sc->LAMBDA) {
tinyscheme_genesi... 2719 x=cdr(x);
tinyscheme_genesi... 2720 }
tinyscheme_genesi... 2721 if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 2722 y=sc->envir;
tinyscheme_genesi... 2723 } else {
tinyscheme_genesi... 2724 y=cadr(sc->args);
tinyscheme_genesi... 2725 }
tinyscheme_genesi... 2726 s_return(sc,mk_closure(sc, x, y));
tinyscheme_genesi... 2727
tinyscheme_genesi... 2728 case OP_QUOTE:
tinyscheme_genesi... 2729 s_return(sc,car(sc->code));
tinyscheme_genesi... 2730
tinyscheme_genesi... 2731 case OP_DEF0:
tinyscheme_genesi... 2732 if(is_immutable(car(sc->code)))
tinyscheme_genesi... 2733 Error_1(sc,"define: unable to alter immutable", car(sc->code));
tinyscheme_genesi... 2734
tinyscheme_genesi... 2735 if (is_pair(car(sc->code))) {
tinyscheme_genesi... 2736 x = caar(sc->code);
tinyscheme_genesi... 2737 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
tinyscheme_genesi... 2738 } else {
tinyscheme_genesi... 2739 x = car(sc->code);
tinyscheme_genesi... 2740 sc->code = cadr(sc->code);
tinyscheme_genesi... 2741 }
tinyscheme_genesi... 2742 if (!is_symbol(x)) {
tinyscheme_genesi... 2743 Error_0(sc,"variable is not a symbol");
tinyscheme_genesi... 2744 }
tinyscheme_genesi... 2745 s_save(sc,OP_DEF1, sc->NIL, x);
tinyscheme_genesi... 2746 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2747
tinyscheme_genesi... 2748 case OP_DEF1:
tinyscheme_genesi... 2749 x=find_slot_in_env(sc,sc->envir,sc->code,0);
tinyscheme_genesi... 2750 if (x != sc->NIL) {
tinyscheme_genesi... 2751 set_slot_in_env(sc, x, sc->value);
tinyscheme_genesi... 2752 } else {
tinyscheme_genesi... 2753 new_slot_in_env(sc, sc->code, sc->value);
tinyscheme_genesi... 2754 }
tinyscheme_genesi... 2755 s_return(sc,sc->code);
tinyscheme_genesi... 2756
tinyscheme_genesi... 2757
tinyscheme_genesi... 2758 case OP_DEFP:
tinyscheme_genesi... 2759 x=sc->envir;
tinyscheme_genesi... 2760 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 2761 x=cadr(sc->args);
tinyscheme_genesi... 2762 }
tinyscheme_genesi... 2763 s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
tinyscheme_genesi... 2764
tinyscheme_genesi... 2765 case OP_SET0:
tinyscheme_genesi... 2766 if(is_immutable(car(sc->code)))
tinyscheme_genesi... 2767 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
tinyscheme_genesi... 2768 s_save(sc,OP_SET1, sc->NIL, car(sc->code));
tinyscheme_genesi... 2769 sc->code = cadr(sc->code);
tinyscheme_genesi... 2770 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2771
tinyscheme_genesi... 2772 case OP_SET1:
tinyscheme_genesi... 2773 y=find_slot_in_env(sc,sc->envir,sc->code,1);
tinyscheme_genesi... 2774 if (y != sc->NIL) {
tinyscheme_genesi... 2775 set_slot_in_env(sc, y, sc->value);
tinyscheme_genesi... 2776 s_return(sc,sc->value);
tinyscheme_genesi... 2777 } else {
tinyscheme_genesi... 2778 Error_1(sc,"set!: unbound variable:", sc->code);
tinyscheme_genesi... 2779 }
tinyscheme_genesi... 2780
tinyscheme_genesi... 2781
tinyscheme_genesi... 2782 case OP_BEGIN:
tinyscheme_genesi... 2783 if (!is_pair(sc->code)) {
tinyscheme_genesi... 2784 s_return(sc,sc->code);
tinyscheme_genesi... 2785 }
tinyscheme_genesi... 2786 if (cdr(sc->code) != sc->NIL) {
tinyscheme_genesi... 2787 s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2788 }
tinyscheme_genesi... 2789 sc->code = car(sc->code);
tinyscheme_genesi... 2790 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2791
tinyscheme_genesi... 2792 case OP_IF0:
tinyscheme_genesi... 2793 s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2794 sc->code = car(sc->code);
tinyscheme_genesi... 2795 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2796
tinyscheme_genesi... 2797 case OP_IF1:
tinyscheme_genesi... 2798 if (is_true(sc->value))
tinyscheme_genesi... 2799 sc->code = car(sc->code);
tinyscheme_genesi... 2800 else
tinyscheme_genesi... 2801 sc->code = cadr(sc->code);
tinyscheme_genesi... 2802 * car(sc->NIL) = sc->NIL */
tinyscheme_genesi... 2803 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2804
tinyscheme_genesi... 2805 case OP_LET0:
tinyscheme_genesi... 2806 sc->args = sc->NIL;
tinyscheme_genesi... 2807 sc->value = sc->code;
tinyscheme_genesi... 2808 sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
tinyscheme_genesi... 2809 s_goto(sc,OP_LET1);
tinyscheme_genesi... 2810
tinyscheme_genesi... 2811 case OP_LET1:
tinyscheme_genesi... 2812 sc->args = cons(sc, sc->value, sc->args);
tinyscheme_genesi... 2813 if (is_pair(sc->code)) {
tinyscheme_genesi... 2814 if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
tinyscheme_genesi... 2815 Error_1(sc, "Bad syntax of binding spec in let :",
tinyscheme_genesi... 2816 car(sc->code));
tinyscheme_genesi... 2817 }
tinyscheme_genesi... 2818 s_save(sc,OP_LET1, sc->args, cdr(sc->code));
tinyscheme_genesi... 2819 sc->code = cadar(sc->code);
tinyscheme_genesi... 2820 sc->args = sc->NIL;
tinyscheme_genesi... 2821 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2822 } else {
tinyscheme_genesi... 2823 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
tinyscheme_genesi... 2824 sc->code = car(sc->args);
tinyscheme_genesi... 2825 sc->args = cdr(sc->args);
tinyscheme_genesi... 2826 s_goto(sc,OP_LET2);
tinyscheme_genesi... 2827 }
tinyscheme_genesi... 2828
tinyscheme_genesi... 2829 case OP_LET2:
tinyscheme_genesi... 2830 new_frame_in_env(sc, sc->envir);
tinyscheme_genesi... 2831 for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
tinyscheme_genesi... 2832 y != sc->NIL; x = cdr(x), y = cdr(y)) {
tinyscheme_genesi... 2833 new_slot_in_env(sc, caar(x), car(y));
tinyscheme_genesi... 2834 }
tinyscheme_genesi... 2835 if (is_symbol(car(sc->code))) {
tinyscheme_genesi... 2836 for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 2837 if (!is_pair(x))
tinyscheme_genesi... 2838 Error_1(sc, "Bad syntax of binding in let :", x);
tinyscheme_genesi... 2839 if (!is_list(sc, car(x)))
tinyscheme_genesi... 2840 Error_1(sc, "Bad syntax of binding in let :", car(x));
tinyscheme_genesi... 2841 sc->args = cons(sc, caar(x), sc->args);
tinyscheme_genesi... 2842 }
tinyscheme_genesi... 2843 x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
tinyscheme_genesi... 2844 new_slot_in_env(sc, car(sc->code), x);
tinyscheme_genesi... 2845 sc->code = cddr(sc->code);
tinyscheme_genesi... 2846 sc->args = sc->NIL;
tinyscheme_genesi... 2847 } else {
tinyscheme_genesi... 2848 sc->code = cdr(sc->code);
tinyscheme_genesi... 2849 sc->args = sc->NIL;
tinyscheme_genesi... 2850 }
tinyscheme_genesi... 2851 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2852
tinyscheme_genesi... 2853 case OP_LET0AST:
tinyscheme_genesi... 2854 if (car(sc->code) == sc->NIL) {
tinyscheme_genesi... 2855 new_frame_in_env(sc, sc->envir);
tinyscheme_genesi... 2856 sc->code = cdr(sc->code);
tinyscheme_genesi... 2857 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2858 }
tinyscheme_genesi... 2859 if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
tinyscheme_genesi... 2860 Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
tinyscheme_genesi... 2861 }
tinyscheme_genesi... 2862 s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
tinyscheme_genesi... 2863 sc->code = cadaar(sc->code);
tinyscheme_genesi... 2864 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2865
tinyscheme_genesi... 2866 case OP_LET1AST:
tinyscheme_genesi... 2867 new_frame_in_env(sc, sc->envir);
tinyscheme_genesi... 2868 s_goto(sc,OP_LET2AST);
tinyscheme_genesi... 2869
tinyscheme_genesi... 2870 case OP_LET2AST:
tinyscheme_genesi... 2871 new_slot_in_env(sc, caar(sc->code), sc->value);
tinyscheme_genesi... 2872 sc->code = cdr(sc->code);
tinyscheme_genesi... 2873 if (is_pair(sc->code)) {
tinyscheme_genesi... 2874 s_save(sc,OP_LET2AST, sc->args, sc->code);
tinyscheme_genesi... 2875 sc->code = cadar(sc->code);
tinyscheme_genesi... 2876 sc->args = sc->NIL;
tinyscheme_genesi... 2877 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2878 } else {
tinyscheme_genesi... 2879 sc->code = sc->args;
tinyscheme_genesi... 2880 sc->args = sc->NIL;
tinyscheme_genesi... 2881 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2882 }
tinyscheme_genesi... 2883 default:
tinyscheme_genesi... 2884 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 2885 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 2886 }
tinyscheme_genesi... 2887 return sc->T;
tinyscheme_genesi... 2888 }
tinyscheme_genesi... 2889
tinyscheme_genesi... 2890 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 2891 pointer x, y;
tinyscheme_genesi... 2892
tinyscheme_genesi... 2893 switch (op) {
tinyscheme_genesi... 2894 case OP_LET0REC:
tinyscheme_genesi... 2895 new_frame_in_env(sc, sc->envir);
tinyscheme_genesi... 2896 sc->args = sc->NIL;
tinyscheme_genesi... 2897 sc->value = sc->code;
tinyscheme_genesi... 2898 sc->code = car(sc->code);
tinyscheme_genesi... 2899 s_goto(sc,OP_LET1REC);
tinyscheme_genesi... 2900
tinyscheme_genesi... 2901 case OP_LET1REC:
tinyscheme_genesi... 2902 sc->args = cons(sc, sc->value, sc->args);
tinyscheme_genesi... 2903 if (is_pair(sc->code)) {
tinyscheme_genesi... 2904 if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
tinyscheme_genesi... 2905 Error_1(sc, "Bad syntax of binding spec in letrec :",
tinyscheme_genesi... 2906 car(sc->code));
tinyscheme_genesi... 2907 }
tinyscheme_genesi... 2908 s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
tinyscheme_genesi... 2909 sc->code = cadar(sc->code);
tinyscheme_genesi... 2910 sc->args = sc->NIL;
tinyscheme_genesi... 2911 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2912 } else {
tinyscheme_genesi... 2913 sc->args = reverse_in_place(sc, sc->NIL, sc->args);
tinyscheme_genesi... 2914 sc->code = car(sc->args);
tinyscheme_genesi... 2915 sc->args = cdr(sc->args);
tinyscheme_genesi... 2916 s_goto(sc,OP_LET2REC);
tinyscheme_genesi... 2917 }
tinyscheme_genesi... 2918
tinyscheme_genesi... 2919 case OP_LET2REC:
tinyscheme_genesi... 2920 for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
tinyscheme_genesi... 2921 new_slot_in_env(sc, caar(x), car(y));
tinyscheme_genesi... 2922 }
tinyscheme_genesi... 2923 sc->code = cdr(sc->code);
tinyscheme_genesi... 2924 sc->args = sc->NIL;
tinyscheme_genesi... 2925 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2926
tinyscheme_genesi... 2927 case OP_COND0:
tinyscheme_genesi... 2928 if (!is_pair(sc->code)) {
tinyscheme_genesi... 2929 Error_0(sc,"syntax error in cond");
tinyscheme_genesi... 2930 }
tinyscheme_genesi... 2931 s_save(sc,OP_COND1, sc->NIL, sc->code);
tinyscheme_genesi... 2932 sc->code = caar(sc->code);
tinyscheme_genesi... 2933 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2934
tinyscheme_genesi... 2935 case OP_COND1:
tinyscheme_genesi... 2936 if (is_true(sc->value)) {
tinyscheme_genesi... 2937 if ((sc->code = cdar(sc->code)) == sc->NIL) {
tinyscheme_genesi... 2938 s_return(sc,sc->value);
tinyscheme_genesi... 2939 }
tinyscheme_genesi... 2940 if(car(sc->code)==sc->FEED_TO) {
tinyscheme_genesi... 2941 if(!is_pair(cdr(sc->code))) {
tinyscheme_genesi... 2942 Error_0(sc,"syntax error in cond");
tinyscheme_genesi... 2943 }
tinyscheme_genesi... 2944 x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
tinyscheme_genesi... 2945 sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
tinyscheme_genesi... 2946 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2947 }
tinyscheme_genesi... 2948 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 2949 } else {
tinyscheme_genesi... 2950 if ((sc->code = cdr(sc->code)) == sc->NIL) {
tinyscheme_genesi... 2951 s_return(sc,sc->NIL);
tinyscheme_genesi... 2952 } else {
tinyscheme_genesi... 2953 s_save(sc,OP_COND1, sc->NIL, sc->code);
tinyscheme_genesi... 2954 sc->code = caar(sc->code);
tinyscheme_genesi... 2955 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2956 }
tinyscheme_genesi... 2957 }
tinyscheme_genesi... 2958
tinyscheme_genesi... 2959 case OP_DELAY:
tinyscheme_genesi... 2960 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
tinyscheme_genesi... 2961 typeflag(x)=T_PROMISE;
tinyscheme_genesi... 2962 s_return(sc,x);
tinyscheme_genesi... 2963
tinyscheme_genesi... 2964 case OP_AND0:
tinyscheme_genesi... 2965 if (sc->code == sc->NIL) {
tinyscheme_genesi... 2966 s_return(sc,sc->T);
tinyscheme_genesi... 2967 }
tinyscheme_genesi... 2968 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2969 sc->code = car(sc->code);
tinyscheme_genesi... 2970 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2971
tinyscheme_genesi... 2972 case OP_AND1:
tinyscheme_genesi... 2973 if (is_false(sc->value)) {
tinyscheme_genesi... 2974 s_return(sc,sc->value);
tinyscheme_genesi... 2975 } else if (sc->code == sc->NIL) {
tinyscheme_genesi... 2976 s_return(sc,sc->value);
tinyscheme_genesi... 2977 } else {
tinyscheme_genesi... 2978 s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2979 sc->code = car(sc->code);
tinyscheme_genesi... 2980 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2981 }
tinyscheme_genesi... 2982
tinyscheme_genesi... 2983 case OP_OR0:
tinyscheme_genesi... 2984 if (sc->code == sc->NIL) {
tinyscheme_genesi... 2985 s_return(sc,sc->F);
tinyscheme_genesi... 2986 }
tinyscheme_genesi... 2987 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2988 sc->code = car(sc->code);
tinyscheme_genesi... 2989 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 2990
tinyscheme_genesi... 2991 case OP_OR1:
tinyscheme_genesi... 2992 if (is_true(sc->value)) {
tinyscheme_genesi... 2993 s_return(sc,sc->value);
tinyscheme_genesi... 2994 } else if (sc->code == sc->NIL) {
tinyscheme_genesi... 2995 s_return(sc,sc->value);
tinyscheme_genesi... 2996 } else {
tinyscheme_genesi... 2997 s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 2998 sc->code = car(sc->code);
tinyscheme_genesi... 2999 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3000 }
tinyscheme_genesi... 3001
tinyscheme_genesi... 3002 case OP_C0STREAM:
tinyscheme_genesi... 3003 s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 3004 sc->code = car(sc->code);
tinyscheme_genesi... 3005 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3006
tinyscheme_genesi... 3007 case OP_C1STREAM:
tinyscheme_genesi... 3008 sc->args = sc->value;
tinyscheme_genesi... 3009 x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
tinyscheme_genesi... 3010 typeflag(x)=T_PROMISE;
tinyscheme_genesi... 3011 s_return(sc,cons(sc, sc->args, x));
tinyscheme_genesi... 3012
tinyscheme_genesi... 3013 case OP_MACRO0:
tinyscheme_genesi... 3014 if (is_pair(car(sc->code))) {
tinyscheme_genesi... 3015 x = caar(sc->code);
tinyscheme_genesi... 3016 sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
tinyscheme_genesi... 3017 } else {
tinyscheme_genesi... 3018 x = car(sc->code);
tinyscheme_genesi... 3019 sc->code = cadr(sc->code);
tinyscheme_genesi... 3020 }
tinyscheme_genesi... 3021 if (!is_symbol(x)) {
tinyscheme_genesi... 3022 Error_0(sc,"variable is not a symbol");
tinyscheme_genesi... 3023 }
tinyscheme_genesi... 3024 s_save(sc,OP_MACRO1, sc->NIL, x);
tinyscheme_genesi... 3025 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3026
tinyscheme_genesi... 3027 case OP_MACRO1:
tinyscheme_genesi... 3028 typeflag(sc->value) = T_MACRO;
tinyscheme_genesi... 3029 x = find_slot_in_env(sc, sc->envir, sc->code, 0);
tinyscheme_genesi... 3030 if (x != sc->NIL) {
tinyscheme_genesi... 3031 set_slot_in_env(sc, x, sc->value);
tinyscheme_genesi... 3032 } else {
tinyscheme_genesi... 3033 new_slot_in_env(sc, sc->code, sc->value);
tinyscheme_genesi... 3034 }
tinyscheme_genesi... 3035 s_return(sc,sc->code);
tinyscheme_genesi... 3036
tinyscheme_genesi... 3037 case OP_CASE0:
tinyscheme_genesi... 3038 s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
tinyscheme_genesi... 3039 sc->code = car(sc->code);
tinyscheme_genesi... 3040 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3041
tinyscheme_genesi... 3042 case OP_CASE1:
tinyscheme_genesi... 3043 for (x = sc->code; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3044 if (!is_pair(y = caar(x))) {
tinyscheme_genesi... 3045 break;
tinyscheme_genesi... 3046 }
tinyscheme_genesi... 3047 for ( ; y != sc->NIL; y = cdr(y)) {
tinyscheme_genesi... 3048 if (eqv(car(y), sc->value)) {
tinyscheme_genesi... 3049 break;
tinyscheme_genesi... 3050 }
tinyscheme_genesi... 3051 }
tinyscheme_genesi... 3052 if (y != sc->NIL) {
tinyscheme_genesi... 3053 break;
tinyscheme_genesi... 3054 }
tinyscheme_genesi... 3055 }
tinyscheme_genesi... 3056 if (x != sc->NIL) {
tinyscheme_genesi... 3057 if (is_pair(caar(x))) {
tinyscheme_genesi... 3058 sc->code = cdar(x);
tinyscheme_genesi... 3059 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 3060 } else {
tinyscheme_genesi... 3061 s_save(sc,OP_CASE2, sc->NIL, cdar(x));
tinyscheme_genesi... 3062 sc->code = caar(x);
tinyscheme_genesi... 3063 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3064 }
tinyscheme_genesi... 3065 } else {
tinyscheme_genesi... 3066 s_return(sc,sc->NIL);
tinyscheme_genesi... 3067 }
tinyscheme_genesi... 3068
tinyscheme_genesi... 3069 case OP_CASE2:
tinyscheme_genesi... 3070 if (is_true(sc->value)) {
tinyscheme_genesi... 3071 s_goto(sc,OP_BEGIN);
tinyscheme_genesi... 3072 } else {
tinyscheme_genesi... 3073 s_return(sc,sc->NIL);
tinyscheme_genesi... 3074 }
tinyscheme_genesi... 3075
tinyscheme_genesi... 3076 case OP_PAPPLY:
tinyscheme_genesi... 3077 sc->code = car(sc->args);
tinyscheme_genesi... 3078 sc->args = list_star(sc,cdr(sc->args));
tinyscheme_genesi... 3079
tinyscheme_genesi... 3080 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 3081
tinyscheme_genesi... 3082 case OP_PEVAL:
tinyscheme_genesi... 3083 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3084 sc->envir=cadr(sc->args);
tinyscheme_genesi... 3085 }
tinyscheme_genesi... 3086 sc->code = car(sc->args);
tinyscheme_genesi... 3087 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 3088
tinyscheme_genesi... 3089 case OP_CONTINUATION:
tinyscheme_genesi... 3090 sc->code = car(sc->args);
tinyscheme_genesi... 3091 sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
tinyscheme_genesi... 3092 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 3093
tinyscheme_genesi... 3094 default:
tinyscheme_genesi... 3095 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 3096 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 3097 }
tinyscheme_genesi... 3098 return sc->T;
tinyscheme_genesi... 3099 }
tinyscheme_genesi... 3100
tinyscheme_genesi... 3101 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 3102 pointer x;
tinyscheme_genesi... 3103 num v;
tinyscheme_genesi... 3104 #if USE_MATH
tinyscheme_genesi... 3105 double dd;
tinyscheme_genesi... 3106 #endif
tinyscheme_genesi... 3107
tinyscheme_genesi... 3108 switch (op) {
tinyscheme_genesi... 3109 #if USE_MATH
tinyscheme_genesi... 3110 case OP_INEX2EX:
tinyscheme_genesi... 3111 x=car(sc->args);
tinyscheme_genesi... 3112 if(num_is_integer(x)) {
tinyscheme_genesi... 3113 s_return(sc,x);
tinyscheme_genesi... 3114 } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
tinyscheme_genesi... 3115 s_return(sc,mk_integer(sc,ivalue(x)));
tinyscheme_genesi... 3116 } else {
tinyscheme_genesi... 3117 Error_1(sc,"inexact->exact: not integral:",x);
tinyscheme_genesi... 3118 }
tinyscheme_genesi... 3119
tinyscheme_genesi... 3120 case OP_EXP:
tinyscheme_genesi... 3121 x=car(sc->args);
tinyscheme_genesi... 3122 s_return(sc, mk_real(sc, exp(rvalue(x))));
tinyscheme_genesi... 3123
tinyscheme_genesi... 3124 case OP_LOG:
tinyscheme_genesi... 3125 x=car(sc->args);
tinyscheme_genesi... 3126 s_return(sc, mk_real(sc, log(rvalue(x))));
tinyscheme_genesi... 3127
tinyscheme_genesi... 3128 case OP_SIN:
tinyscheme_genesi... 3129 x=car(sc->args);
tinyscheme_genesi... 3130 s_return(sc, mk_real(sc, sin(rvalue(x))));
tinyscheme_genesi... 3131
tinyscheme_genesi... 3132 case OP_COS:
tinyscheme_genesi... 3133 x=car(sc->args);
tinyscheme_genesi... 3134 s_return(sc, mk_real(sc, cos(rvalue(x))));
tinyscheme_genesi... 3135
tinyscheme_genesi... 3136 case OP_TAN:
tinyscheme_genesi... 3137 x=car(sc->args);
tinyscheme_genesi... 3138 s_return(sc, mk_real(sc, tan(rvalue(x))));
tinyscheme_genesi... 3139
tinyscheme_genesi... 3140 case OP_ASIN:
tinyscheme_genesi... 3141 x=car(sc->args);
tinyscheme_genesi... 3142 s_return(sc, mk_real(sc, asin(rvalue(x))));
tinyscheme_genesi... 3143
tinyscheme_genesi... 3144 case OP_ACOS:
tinyscheme_genesi... 3145 x=car(sc->args);
tinyscheme_genesi... 3146 s_return(sc, mk_real(sc, acos(rvalue(x))));
tinyscheme_genesi... 3147
tinyscheme_genesi... 3148 case OP_ATAN:
tinyscheme_genesi... 3149 x=car(sc->args);
tinyscheme_genesi... 3150 if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 3151 s_return(sc, mk_real(sc, atan(rvalue(x))));
tinyscheme_genesi... 3152 } else {
tinyscheme_genesi... 3153 pointer y=cadr(sc->args);
tinyscheme_genesi... 3154 s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
tinyscheme_genesi... 3155 }
tinyscheme_genesi... 3156
tinyscheme_genesi... 3157 case OP_SQRT:
tinyscheme_genesi... 3158 x=car(sc->args);
tinyscheme_genesi... 3159 s_return(sc, mk_real(sc, sqrt(rvalue(x))));
tinyscheme_genesi... 3160
tinyscheme_genesi... 3161 case OP_EXPT: {
tinyscheme_genesi... 3162 double result;
tinyscheme_genesi... 3163 int real_result=1;
tinyscheme_genesi... 3164 pointer y=cadr(sc->args);
tinyscheme_genesi... 3165 x=car(sc->args);
tinyscheme_genesi... 3166 if (num_is_integer(x) && num_is_integer(y))
tinyscheme_genesi... 3167 real_result=0;
tinyscheme_genesi... 3168
tinyscheme_genesi... 3169
tinyscheme_genesi... 3170 if (rvalue(x) == 0 && rvalue(y) < 0) {
tinyscheme_genesi... 3171 result = 0.0;
tinyscheme_genesi... 3172 } else {
tinyscheme_genesi... 3173 result = pow(rvalue(x),rvalue(y));
tinyscheme_genesi... 3174 }
tinyscheme_genesi... 3175
tinyscheme_genesi... 3176
tinyscheme_genesi... 3177 if (!real_result)
tinyscheme_genesi... 3178 {
tinyscheme_genesi... 3179 long result_as_long = (long)result;
tinyscheme_genesi... 3180 if (result != (double)result_as_long)
tinyscheme_genesi... 3181 real_result = 1;
tinyscheme_genesi... 3182 }
tinyscheme_genesi... 3183 if (real_result) {
tinyscheme_genesi... 3184 s_return(sc, mk_real(sc, result));
tinyscheme_genesi... 3185 } else {
tinyscheme_genesi... 3186 s_return(sc, mk_integer(sc, result));
tinyscheme_genesi... 3187 }
tinyscheme_genesi... 3188 }
tinyscheme_genesi... 3189
tinyscheme_genesi... 3190 case OP_FLOOR:
tinyscheme_genesi... 3191 x=car(sc->args);
tinyscheme_genesi... 3192 s_return(sc, mk_real(sc, floor(rvalue(x))));
tinyscheme_genesi... 3193
tinyscheme_genesi... 3194 case OP_CEILING:
tinyscheme_genesi... 3195 x=car(sc->args);
tinyscheme_genesi... 3196 s_return(sc, mk_real(sc, ceil(rvalue(x))));
tinyscheme_genesi... 3197
tinyscheme_genesi... 3198 case OP_TRUNCATE : {
tinyscheme_genesi... 3199 double rvalue_of_x ;
tinyscheme_genesi... 3200 x=car(sc->args);
tinyscheme_genesi... 3201 rvalue_of_x = rvalue(x) ;
tinyscheme_genesi... 3202 if (rvalue_of_x > 0) {
tinyscheme_genesi... 3203 s_return(sc, mk_real(sc, floor(rvalue_of_x)));
tinyscheme_genesi... 3204 } else {
tinyscheme_genesi... 3205 s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
tinyscheme_genesi... 3206 }
tinyscheme_genesi... 3207 }
tinyscheme_genesi... 3208
tinyscheme_genesi... 3209 case OP_ROUND:
tinyscheme_genesi... 3210 x=car(sc->args);
tinyscheme_genesi... 3211 if (num_is_integer(x))
tinyscheme_genesi... 3212 s_return(sc, x);
tinyscheme_genesi... 3213 s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
tinyscheme_genesi... 3214 #endif
tinyscheme_genesi... 3215
tinyscheme_genesi... 3216 case OP_ADD:
tinyscheme_genesi... 3217 v=num_zero;
tinyscheme_genesi... 3218 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3219 v=num_add(v,nvalue(car(x)));
tinyscheme_genesi... 3220 }
tinyscheme_genesi... 3221 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3222
tinyscheme_genesi... 3223 case OP_MUL:
tinyscheme_genesi... 3224 v=num_one;
tinyscheme_genesi... 3225 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3226 v=num_mul(v,nvalue(car(x)));
tinyscheme_genesi... 3227 }
tinyscheme_genesi... 3228 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3229
tinyscheme_genesi... 3230 case OP_SUB:
tinyscheme_genesi... 3231 if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 3232 x=sc->args;
tinyscheme_genesi... 3233 v=num_zero;
tinyscheme_genesi... 3234 } else {
tinyscheme_genesi... 3235 x = cdr(sc->args);
tinyscheme_genesi... 3236 v = nvalue(car(sc->args));
tinyscheme_genesi... 3237 }
tinyscheme_genesi... 3238 for (; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3239 v=num_sub(v,nvalue(car(x)));
tinyscheme_genesi... 3240 }
tinyscheme_genesi... 3241 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3242
tinyscheme_genesi... 3243 case OP_DIV:
tinyscheme_genesi... 3244 if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 3245 x=sc->args;
tinyscheme_genesi... 3246 v=num_one;
tinyscheme_genesi... 3247 } else {
tinyscheme_genesi... 3248 x = cdr(sc->args);
tinyscheme_genesi... 3249 v = nvalue(car(sc->args));
tinyscheme_genesi... 3250 }
tinyscheme_genesi... 3251 for (; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3252 if (!is_zero_double(rvalue(car(x))))
tinyscheme_genesi... 3253 v=num_div(v,nvalue(car(x)));
tinyscheme_genesi... 3254 else {
tinyscheme_genesi... 3255 Error_0(sc,"/: division by zero");
tinyscheme_genesi... 3256 }
tinyscheme_genesi... 3257 }
tinyscheme_genesi... 3258 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3259
tinyscheme_genesi... 3260 case OP_INTDIV:
tinyscheme_genesi... 3261 if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 3262 x=sc->args;
tinyscheme_genesi... 3263 v=num_one;
tinyscheme_genesi... 3264 } else {
tinyscheme_genesi... 3265 x = cdr(sc->args);
tinyscheme_genesi... 3266 v = nvalue(car(sc->args));
tinyscheme_genesi... 3267 }
tinyscheme_genesi... 3268 for (; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3269 if (ivalue(car(x)) != 0)
tinyscheme_genesi... 3270 v=num_intdiv(v,nvalue(car(x)));
tinyscheme_genesi... 3271 else {
tinyscheme_genesi... 3272 Error_0(sc,"quotient: division by zero");
tinyscheme_genesi... 3273 }
tinyscheme_genesi... 3274 }
tinyscheme_genesi... 3275 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3276
tinyscheme_genesi... 3277 case OP_REM:
tinyscheme_genesi... 3278 v = nvalue(car(sc->args));
tinyscheme_genesi... 3279 if (ivalue(cadr(sc->args)) != 0)
tinyscheme_genesi... 3280 v=num_rem(v,nvalue(cadr(sc->args)));
tinyscheme_genesi... 3281 else {
tinyscheme_genesi... 3282 Error_0(sc,"remainder: division by zero");
tinyscheme_genesi... 3283 }
tinyscheme_genesi... 3284 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3285
tinyscheme_genesi... 3286 case OP_MOD:
tinyscheme_genesi... 3287 v = nvalue(car(sc->args));
tinyscheme_genesi... 3288 if (ivalue(cadr(sc->args)) != 0)
tinyscheme_genesi... 3289 v=num_mod(v,nvalue(cadr(sc->args)));
tinyscheme_genesi... 3290 else {
tinyscheme_genesi... 3291 Error_0(sc,"modulo: division by zero");
tinyscheme_genesi... 3292 }
tinyscheme_genesi... 3293 s_return(sc,mk_number(sc, v));
tinyscheme_genesi... 3294
tinyscheme_genesi... 3295 case OP_CAR:
tinyscheme_genesi... 3296 s_return(sc,caar(sc->args));
tinyscheme_genesi... 3297
tinyscheme_genesi... 3298 case OP_CDR:
tinyscheme_genesi... 3299 s_return(sc,cdar(sc->args));
tinyscheme_genesi... 3300
tinyscheme_genesi... 3301 case OP_CONS:
tinyscheme_genesi... 3302 cdr(sc->args) = cadr(sc->args);
tinyscheme_genesi... 3303 s_return(sc,sc->args);
tinyscheme_genesi... 3304
tinyscheme_genesi... 3305 case OP_SETCAR:
tinyscheme_genesi... 3306 if(!is_immutable(car(sc->args))) {
tinyscheme_genesi... 3307 caar(sc->args) = cadr(sc->args);
tinyscheme_genesi... 3308 s_return(sc,car(sc->args));
tinyscheme_genesi... 3309 } else {
tinyscheme_genesi... 3310 Error_0(sc,"set-car!: unable to alter immutable pair");
tinyscheme_genesi... 3311 }
tinyscheme_genesi... 3312
tinyscheme_genesi... 3313 case OP_SETCDR:
tinyscheme_genesi... 3314 if(!is_immutable(car(sc->args))) {
tinyscheme_genesi... 3315 cdar(sc->args) = cadr(sc->args);
tinyscheme_genesi... 3316 s_return(sc,car(sc->args));
tinyscheme_genesi... 3317 } else {
tinyscheme_genesi... 3318 Error_0(sc,"set-cdr!: unable to alter immutable pair");
tinyscheme_genesi... 3319 }
tinyscheme_genesi... 3320
tinyscheme_genesi... 3321 case OP_CHAR2INT: {
tinyscheme_genesi... 3322 char c;
tinyscheme_genesi... 3323 c=(char)ivalue(car(sc->args));
tinyscheme_genesi... 3324 s_return(sc,mk_integer(sc,(unsigned char)c));
tinyscheme_genesi... 3325 }
tinyscheme_genesi... 3326
tinyscheme_genesi... 3327 case OP_INT2CHAR: {
tinyscheme_genesi... 3328 unsigned char c;
tinyscheme_genesi... 3329 c=(unsigned char)ivalue(car(sc->args));
tinyscheme_genesi... 3330 s_return(sc,mk_character(sc,(char)c));
tinyscheme_genesi... 3331 }
tinyscheme_genesi... 3332
tinyscheme_genesi... 3333 case OP_CHARUPCASE: {
tinyscheme_genesi... 3334 unsigned char c;
tinyscheme_genesi... 3335 c=(unsigned char)ivalue(car(sc->args));
tinyscheme_genesi... 3336 c=toupper(c);
tinyscheme_genesi... 3337 s_return(sc,mk_character(sc,(char)c));
tinyscheme_genesi... 3338 }
tinyscheme_genesi... 3339
tinyscheme_genesi... 3340 case OP_CHARDNCASE: {
tinyscheme_genesi... 3341 unsigned char c;
tinyscheme_genesi... 3342 c=(unsigned char)ivalue(car(sc->args));
tinyscheme_genesi... 3343 c=tolower(c);
tinyscheme_genesi... 3344 s_return(sc,mk_character(sc,(char)c));
tinyscheme_genesi... 3345 }
tinyscheme_genesi... 3346
tinyscheme_genesi... 3347 case OP_STR2SYM:
tinyscheme_genesi... 3348 s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
tinyscheme_genesi... 3349
tinyscheme_genesi... 3350 case OP_STR2ATOM: {
tinyscheme_genesi... 3351 char *s=strvalue(car(sc->args));
tinyscheme_genesi... 3352 long pf = 0;
tinyscheme_genesi... 3353 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3354
tinyscheme_genesi... 3355
tinyscheme_genesi... 3356 pf = ivalue_unchecked(cadr(sc->args));
tinyscheme_genesi... 3357 if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
tinyscheme_genesi... 3358
tinyscheme_genesi... 3359 }
tinyscheme_genesi... 3360 else {
tinyscheme_genesi... 3361 pf = -1;
tinyscheme_genesi... 3362 }
tinyscheme_genesi... 3363 }
tinyscheme_genesi... 3364 if (pf < 0) {
tinyscheme_genesi... 3365 Error_1(sc, "string->atom: bad base:", cadr(sc->args));
tinyscheme_genesi... 3366 } else if(*s=='#') {
tinyscheme_genesi... 3367 s_return(sc, mk_sharp_const(sc, s+1));
tinyscheme_genesi... 3368 } else {
tinyscheme_genesi... 3369 if (pf == 0 || pf == 10) {
tinyscheme_genesi... 3370 s_return(sc, mk_atom(sc, s));
tinyscheme_genesi... 3371 }
tinyscheme_genesi... 3372 else {
tinyscheme_genesi... 3373 char *ep;
tinyscheme_genesi... 3374 long iv = strtol(s,&ep,(int )pf);
tinyscheme_genesi... 3375 if (*ep == 0) {
tinyscheme_genesi... 3376 s_return(sc, mk_integer(sc, iv));
tinyscheme_genesi... 3377 }
tinyscheme_genesi... 3378 else {
tinyscheme_genesi... 3379 s_return(sc, sc->F);
tinyscheme_genesi... 3380 }
tinyscheme_genesi... 3381 }
tinyscheme_genesi... 3382 }
tinyscheme_genesi... 3383 }
tinyscheme_genesi... 3384
tinyscheme_genesi... 3385 case OP_SYM2STR:
tinyscheme_genesi... 3386 x=mk_string(sc,symname(car(sc->args)));
tinyscheme_genesi... 3387 setimmutable(x);
tinyscheme_genesi... 3388 s_return(sc,x);
tinyscheme_genesi... 3389
tinyscheme_genesi... 3390 case OP_ATOM2STR: {
tinyscheme_genesi... 3391 long pf = 0;
tinyscheme_genesi... 3392 x=car(sc->args);
tinyscheme_genesi... 3393 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3394
tinyscheme_genesi... 3395
tinyscheme_genesi... 3396 pf = ivalue_unchecked(cadr(sc->args));
tinyscheme_genesi... 3397 if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
tinyscheme_genesi... 3398
tinyscheme_genesi... 3399 }
tinyscheme_genesi... 3400 else {
tinyscheme_genesi... 3401 pf = -1;
tinyscheme_genesi... 3402 }
tinyscheme_genesi... 3403 }
tinyscheme_genesi... 3404 if (pf < 0) {
tinyscheme_genesi... 3405 Error_1(sc, "atom->string: bad base:", cadr(sc->args));
tinyscheme_genesi... 3406 } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
tinyscheme_genesi... 3407 char *p;
tinyscheme_genesi... 3408 int len;
tinyscheme_genesi... 3409 atom2str(sc,x,(int )pf,&p,&len);
tinyscheme_genesi... 3410 s_return(sc,mk_counted_string(sc,p,len));
tinyscheme_genesi... 3411 } else {
tinyscheme_genesi... 3412 Error_1(sc, "atom->string: not an atom:", x);
tinyscheme_genesi... 3413 }
tinyscheme_genesi... 3414 }
tinyscheme_genesi... 3415
tinyscheme_genesi... 3416 case OP_MKSTRING: {
tinyscheme_genesi... 3417 int fill=' ';
tinyscheme_genesi... 3418 int len;
tinyscheme_genesi... 3419
tinyscheme_genesi... 3420 len=ivalue(car(sc->args));
tinyscheme_genesi... 3421
tinyscheme_genesi... 3422 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3423 fill=charvalue(cadr(sc->args));
tinyscheme_genesi... 3424 }
tinyscheme_genesi... 3425 s_return(sc,mk_empty_string(sc,len,(char)fill));
tinyscheme_genesi... 3426 }
tinyscheme_genesi... 3427
tinyscheme_genesi... 3428 case OP_STRLEN:
tinyscheme_genesi... 3429 s_return(sc,mk_integer(sc,strlength(car(sc->args))));
tinyscheme_genesi... 3430
tinyscheme_genesi... 3431 case OP_STRREF: {
tinyscheme_genesi... 3432 char *str;
tinyscheme_genesi... 3433 int index;
tinyscheme_genesi... 3434
tinyscheme_genesi... 3435 str=strvalue(car(sc->args));
tinyscheme_genesi... 3436
tinyscheme_genesi... 3437 index=ivalue(cadr(sc->args));
tinyscheme_genesi... 3438
tinyscheme_genesi... 3439 if(index>=strlength(car(sc->args))) {
tinyscheme_genesi... 3440 Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 3441 }
tinyscheme_genesi... 3442
tinyscheme_genesi... 3443 s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
tinyscheme_genesi... 3444 }
tinyscheme_genesi... 3445
tinyscheme_genesi... 3446 case OP_STRSET: {
tinyscheme_genesi... 3447 char *str;
tinyscheme_genesi... 3448 int index;
tinyscheme_genesi... 3449 int c;
tinyscheme_genesi... 3450
tinyscheme_genesi... 3451 if(is_immutable(car(sc->args))) {
tinyscheme_genesi... 3452 Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
tinyscheme_genesi... 3453 }
tinyscheme_genesi... 3454 str=strvalue(car(sc->args));
tinyscheme_genesi... 3455
tinyscheme_genesi... 3456 index=ivalue(cadr(sc->args));
tinyscheme_genesi... 3457 if(index>=strlength(car(sc->args))) {
tinyscheme_genesi... 3458 Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 3459 }
tinyscheme_genesi... 3460
tinyscheme_genesi... 3461 c=charvalue(caddr(sc->args));
tinyscheme_genesi... 3462
tinyscheme_genesi... 3463 str[index]=(char)c;
tinyscheme_genesi... 3464 s_return(sc,car(sc->args));
tinyscheme_genesi... 3465 }
tinyscheme_genesi... 3466
tinyscheme_genesi... 3467 case OP_STRAPPEND: {
tinyscheme_genesi... 3468
tinyscheme_genesi... 3469 int len = 0;
tinyscheme_genesi... 3470 pointer newstr;
tinyscheme_genesi... 3471 char *pos;
tinyscheme_genesi... 3472
tinyscheme_genesi... 3473
tinyscheme_genesi... 3474 for (x = sc->args; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3475 len += strlength(car(x));
tinyscheme_genesi... 3476 }
tinyscheme_genesi... 3477 newstr = mk_empty_string(sc, len, ' ');
tinyscheme_genesi... 3478
tinyscheme_genesi... 3479 for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
tinyscheme_genesi... 3480 pos += strlength(car(x)), x = cdr(x)) {
tinyscheme_genesi... 3481 memcpy(pos, strvalue(car(x)), strlength(car(x)));
tinyscheme_genesi... 3482 }
tinyscheme_genesi... 3483 s_return(sc, newstr);
tinyscheme_genesi... 3484 }
tinyscheme_genesi... 3485
tinyscheme_genesi... 3486 case OP_SUBSTR: {
tinyscheme_genesi... 3487 char *str;
tinyscheme_genesi... 3488 int index0;
tinyscheme_genesi... 3489 int index1;
tinyscheme_genesi... 3490 int len;
tinyscheme_genesi... 3491
tinyscheme_genesi... 3492 str=strvalue(car(sc->args));
tinyscheme_genesi... 3493
tinyscheme_genesi... 3494 index0=ivalue(cadr(sc->args));
tinyscheme_genesi... 3495
tinyscheme_genesi... 3496 if(index0>strlength(car(sc->args))) {
tinyscheme_genesi... 3497 Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
tinyscheme_genesi... 3498 }
tinyscheme_genesi... 3499
tinyscheme_genesi... 3500 if(cddr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3501 index1=ivalue(caddr(sc->args));
tinyscheme_genesi... 3502 if(index1>strlength(car(sc->args)) || index1<index0) {
tinyscheme_genesi... 3503 Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
tinyscheme_genesi... 3504 }
tinyscheme_genesi... 3505 } else {
tinyscheme_genesi... 3506 index1=strlength(car(sc->args));
tinyscheme_genesi... 3507 }
tinyscheme_genesi... 3508
tinyscheme_genesi... 3509 len=index1-index0;
tinyscheme_genesi... 3510 x=mk_empty_string(sc,len,' ');
tinyscheme_genesi... 3511 memcpy(strvalue(x),str+index0,len);
tinyscheme_genesi... 3512 strvalue(x)[len]=0;
tinyscheme_genesi... 3513
tinyscheme_genesi... 3514 s_return(sc,x);
tinyscheme_genesi... 3515 }
tinyscheme_genesi... 3516
tinyscheme_genesi... 3517 case OP_VECTOR: {
tinyscheme_genesi... 3518 int i;
tinyscheme_genesi... 3519 pointer vec;
tinyscheme_genesi... 3520 int len=list_length(sc,sc->args);
tinyscheme_genesi... 3521 if(len<0) {
tinyscheme_genesi... 3522 Error_1(sc,"vector: not a proper list:",sc->args);
tinyscheme_genesi... 3523 }
tinyscheme_genesi... 3524 vec=mk_vector(sc,len);
tinyscheme_genesi... 3525 if(sc->no_memory) { s_return(sc, sc->sink); }
tinyscheme_genesi... 3526 for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
tinyscheme_genesi... 3527 set_vector_elem(vec,i,car(x));
tinyscheme_genesi... 3528 }
tinyscheme_genesi... 3529 s_return(sc,vec);
tinyscheme_genesi... 3530 }
tinyscheme_genesi... 3531
tinyscheme_genesi... 3532 case OP_MKVECTOR: {
tinyscheme_genesi... 3533 pointer fill=sc->NIL;
tinyscheme_genesi... 3534 int len;
tinyscheme_genesi... 3535 pointer vec;
tinyscheme_genesi... 3536
tinyscheme_genesi... 3537 len=ivalue(car(sc->args));
tinyscheme_genesi... 3538
tinyscheme_genesi... 3539 if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 3540 fill=cadr(sc->args);
tinyscheme_genesi... 3541 }
tinyscheme_genesi... 3542 vec=mk_vector(sc,len);
tinyscheme_genesi... 3543 if(sc->no_memory) { s_return(sc, sc->sink); }
tinyscheme_genesi... 3544 if(fill!=sc->NIL) {
tinyscheme_genesi... 3545 fill_vector(vec,fill);
tinyscheme_genesi... 3546 }
tinyscheme_genesi... 3547 s_return(sc,vec);
tinyscheme_genesi... 3548 }
tinyscheme_genesi... 3549
tinyscheme_genesi... 3550 case OP_VECLEN:
tinyscheme_genesi... 3551 s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
tinyscheme_genesi... 3552
tinyscheme_genesi... 3553 case OP_VECREF: {
tinyscheme_genesi... 3554 int index;
tinyscheme_genesi... 3555
tinyscheme_genesi... 3556 index=ivalue(cadr(sc->args));
tinyscheme_genesi... 3557
tinyscheme_genesi... 3558 if(index>=ivalue(car(sc->args))) {
tinyscheme_genesi... 3559 Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 3560 }
tinyscheme_genesi... 3561
tinyscheme_genesi... 3562 s_return(sc,vector_elem(car(sc->args),index));
tinyscheme_genesi... 3563 }
tinyscheme_genesi... 3564
tinyscheme_genesi... 3565 case OP_VECSET: {
tinyscheme_genesi... 3566 int index;
tinyscheme_genesi... 3567
tinyscheme_genesi... 3568 if(is_immutable(car(sc->args))) {
tinyscheme_genesi... 3569 Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
tinyscheme_genesi... 3570 }
tinyscheme_genesi... 3571
tinyscheme_genesi... 3572 index=ivalue(cadr(sc->args));
tinyscheme_genesi... 3573 if(index>=ivalue(car(sc->args))) {
tinyscheme_genesi... 3574 Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 3575 }
tinyscheme_genesi... 3576
tinyscheme_genesi... 3577 set_vector_elem(car(sc->args),index,caddr(sc->args));
tinyscheme_genesi... 3578 s_return(sc,car(sc->args));
tinyscheme_genesi... 3579 }
tinyscheme_genesi... 3580
tinyscheme_genesi... 3581 default:
tinyscheme_genesi... 3582 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 3583 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 3584 }
tinyscheme_genesi... 3585 return sc->T;
tinyscheme_genesi... 3586 }
tinyscheme_genesi... 3587
tinyscheme_genesi... 3588 static int is_list(scheme *sc, pointer a)
tinyscheme_genesi... 3589 { return list_length(sc,a) >= 0; }
tinyscheme_genesi... 3590
tinyscheme_genesi... 3591
tinyscheme_genesi... 3592 proper list: length
tinyscheme_genesi... 3593 circular list: -1
tinyscheme_genesi... 3594 not even a pair: -2
tinyscheme_genesi... 3595 dotted list: -2 minus length before dot
tinyscheme_genesi... 3596 */
tinyscheme_genesi... 3597 int list_length(scheme *sc, pointer a) {
tinyscheme_genesi... 3598 int i=0;
tinyscheme_genesi... 3599 pointer slow, fast;
tinyscheme_genesi... 3600
tinyscheme_genesi... 3601 slow = fast = a;
tinyscheme_genesi... 3602 while (1)
tinyscheme_genesi... 3603 {
tinyscheme_genesi... 3604 if (fast == sc->NIL)
tinyscheme_genesi... 3605 return i;
tinyscheme_genesi... 3606 if (!is_pair(fast))
tinyscheme_genesi... 3607 return -2 - i;
tinyscheme_genesi... 3608 fast = cdr(fast);
tinyscheme_genesi... 3609 ++i;
tinyscheme_genesi... 3610 if (fast == sc->NIL)
tinyscheme_genesi... 3611 return i;
tinyscheme_genesi... 3612 if (!is_pair(fast))
tinyscheme_genesi... 3613 return -2 - i;
tinyscheme_genesi... 3614 ++i;
tinyscheme_genesi... 3615 fast = cdr(fast);
tinyscheme_genesi... 3616
tinyscheme_genesi... 3617
tinyscheme_genesi... 3618 encountered a non-pair. */
tinyscheme_genesi... 3619 slow = cdr(slow);
tinyscheme_genesi... 3620 if (fast == slow)
tinyscheme_genesi... 3621 {
tinyscheme_genesi... 3622
tinyscheme_genesi... 3623 with the slow pointer, hence the structure is circular,
tinyscheme_genesi... 3624 not of finite length, and therefore not a list */
tinyscheme_genesi... 3625 return -1;
tinyscheme_genesi... 3626 }
tinyscheme_genesi... 3627 }
tinyscheme_genesi... 3628 }
tinyscheme_genesi... 3629
tinyscheme_genesi... 3630 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 3631 pointer x;
tinyscheme_genesi... 3632 num v;
tinyscheme_genesi... 3633 int (*comp_func)(num,num)=0;
tinyscheme_genesi... 3634
tinyscheme_genesi... 3635 switch (op) {
tinyscheme_genesi... 3636 case OP_NOT:
tinyscheme_genesi... 3637 s_retbool(is_false(car(sc->args)));
tinyscheme_genesi... 3638 case OP_BOOLP:
tinyscheme_genesi... 3639 s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
tinyscheme_genesi... 3640 case OP_EOFOBJP:
tinyscheme_genesi... 3641 s_retbool(car(sc->args) == sc->EOF_OBJ);
tinyscheme_genesi... 3642 case OP_NULLP:
tinyscheme_genesi... 3643 s_retbool(car(sc->args) == sc->NIL);
tinyscheme_genesi... 3644 case OP_NUMEQ:
tinyscheme_genesi... 3645 case OP_LESS:
tinyscheme_genesi... 3646 case OP_GRE:
tinyscheme_genesi... 3647 case OP_LEQ:
tinyscheme_genesi... 3648 case OP_GEQ:
tinyscheme_genesi... 3649 switch(op) {
tinyscheme_genesi... 3650 case OP_NUMEQ: comp_func=num_eq; break;
tinyscheme_genesi... 3651 case OP_LESS: comp_func=num_lt; break;
tinyscheme_genesi... 3652 case OP_GRE: comp_func=num_gt; break;
tinyscheme_genesi... 3653 case OP_LEQ: comp_func=num_le; break;
tinyscheme_genesi... 3654 case OP_GEQ: comp_func=num_ge; break;
tinyscheme_genesi... 3655 }
tinyscheme_genesi... 3656 x=sc->args;
tinyscheme_genesi... 3657 v=nvalue(car(x));
tinyscheme_genesi... 3658 x=cdr(x);
tinyscheme_genesi... 3659
tinyscheme_genesi... 3660 for (; x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3661 if(!comp_func(v,nvalue(car(x)))) {
tinyscheme_genesi... 3662 s_retbool(0);
tinyscheme_genesi... 3663 }
tinyscheme_genesi... 3664 v=nvalue(car(x));
tinyscheme_genesi... 3665 }
tinyscheme_genesi... 3666 s_retbool(1);
tinyscheme_genesi... 3667 case OP_SYMBOLP:
tinyscheme_genesi... 3668 s_retbool(is_symbol(car(sc->args)));
tinyscheme_genesi... 3669 case OP_NUMBERP:
tinyscheme_genesi... 3670 s_retbool(is_number(car(sc->args)));
tinyscheme_genesi... 3671 case OP_STRINGP:
tinyscheme_genesi... 3672 s_retbool(is_string(car(sc->args)));
tinyscheme_genesi... 3673 case OP_INTEGERP:
tinyscheme_genesi... 3674 s_retbool(is_integer(car(sc->args)));
tinyscheme_genesi... 3675 case OP_REALP:
tinyscheme_genesi... 3676 s_retbool(is_number(car(sc->args)));
tinyscheme_genesi... 3677 case OP_CHARP:
tinyscheme_genesi... 3678 s_retbool(is_character(car(sc->args)));
tinyscheme_genesi... 3679 #if USE_CHAR_CLASSIFIERS
tinyscheme_genesi... 3680 case OP_CHARAP:
tinyscheme_genesi... 3681 s_retbool(Cisalpha(ivalue(car(sc->args))));
tinyscheme_genesi... 3682 case OP_CHARNP:
tinyscheme_genesi... 3683 s_retbool(Cisdigit(ivalue(car(sc->args))));
tinyscheme_genesi... 3684 case OP_CHARWP:
tinyscheme_genesi... 3685 s_retbool(Cisspace(ivalue(car(sc->args))));
tinyscheme_genesi... 3686 case OP_CHARUP:
tinyscheme_genesi... 3687 s_retbool(Cisupper(ivalue(car(sc->args))));
tinyscheme_genesi... 3688 case OP_CHARLP:
tinyscheme_genesi... 3689 s_retbool(Cislower(ivalue(car(sc->args))));
tinyscheme_genesi... 3690 #endif
tinyscheme_genesi... 3691 case OP_PORTP:
tinyscheme_genesi... 3692 s_retbool(is_port(car(sc->args)));
tinyscheme_genesi... 3693 case OP_INPORTP:
tinyscheme_genesi... 3694 s_retbool(is_inport(car(sc->args)));
tinyscheme_genesi... 3695 case OP_OUTPORTP:
tinyscheme_genesi... 3696 s_retbool(is_outport(car(sc->args)));
tinyscheme_genesi... 3697 case OP_PROCP:
tinyscheme_genesi... 3698
tinyscheme_genesi... 3699 * continuation should be procedure by the example
tinyscheme_genesi... 3700 * (call-with-current-continuation procedure?) ==> #t
tinyscheme_genesi... 3701 * in R^3 report sec. 6.9
tinyscheme_genesi... 3702 */
tinyscheme_genesi... 3703 s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
tinyscheme_genesi... 3704 || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
tinyscheme_genesi... 3705 case OP_PAIRP:
tinyscheme_genesi... 3706 s_retbool(is_pair(car(sc->args)));
tinyscheme_genesi... 3707 case OP_LISTP:
tinyscheme_genesi... 3708 s_retbool(list_length(sc,car(sc->args)) >= 0);
tinyscheme_genesi... 3709
tinyscheme_genesi... 3710 case OP_ENVP:
tinyscheme_genesi... 3711 s_retbool(is_environment(car(sc->args)));
tinyscheme_genesi... 3712 case OP_VECTORP:
tinyscheme_genesi... 3713 s_retbool(is_vector(car(sc->args)));
tinyscheme_genesi... 3714 case OP_EQ:
tinyscheme_genesi... 3715 s_retbool(car(sc->args) == cadr(sc->args));
tinyscheme_genesi... 3716 case OP_EQV:
tinyscheme_genesi... 3717 s_retbool(eqv(car(sc->args), cadr(sc->args)));
tinyscheme_genesi... 3718 default:
tinyscheme_genesi... 3719 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 3720 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 3721 }
tinyscheme_genesi... 3722 return sc->T;
tinyscheme_genesi... 3723 }
tinyscheme_genesi... 3724
tinyscheme_genesi... 3725 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 3726 pointer x, y;
tinyscheme_genesi... 3727
tinyscheme_genesi... 3728 switch (op) {
tinyscheme_genesi... 3729 case OP_FORCE:
tinyscheme_genesi... 3730 sc->code = car(sc->args);
tinyscheme_genesi... 3731 if (is_promise(sc->code)) {
tinyscheme_genesi... 3732
tinyscheme_genesi... 3733 s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
tinyscheme_genesi... 3734 sc->args = sc->NIL;
tinyscheme_genesi... 3735 s_goto(sc,OP_APPLY);
tinyscheme_genesi... 3736 } else {
tinyscheme_genesi... 3737 s_return(sc,sc->code);
tinyscheme_genesi... 3738 }
tinyscheme_genesi... 3739
tinyscheme_genesi... 3740 case OP_SAVE_FORCED:
tinyscheme_genesi... 3741 memcpy(sc->code,sc->value,sizeof(struct cell));
tinyscheme_genesi... 3742 s_return(sc,sc->value);
tinyscheme_genesi... 3743
tinyscheme_genesi... 3744 case OP_WRITE:
tinyscheme_genesi... 3745 case OP_DISPLAY:
tinyscheme_genesi... 3746 case OP_WRITE_CHAR:
tinyscheme_genesi... 3747 if(is_pair(cdr(sc->args))) {
tinyscheme_genesi... 3748 if(cadr(sc->args)!=sc->outport) {
tinyscheme_genesi... 3749 x=cons(sc,sc->outport,sc->NIL);
tinyscheme_genesi... 3750 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
tinyscheme_genesi... 3751 sc->outport=cadr(sc->args);
tinyscheme_genesi... 3752 }
tinyscheme_genesi... 3753 }
tinyscheme_genesi... 3754 sc->args = car(sc->args);
tinyscheme_genesi... 3755 if(op==OP_WRITE) {
tinyscheme_genesi... 3756 sc->print_flag = 1;
tinyscheme_genesi... 3757 } else {
tinyscheme_genesi... 3758 sc->print_flag = 0;
tinyscheme_genesi... 3759 }
tinyscheme_genesi... 3760 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 3761
tinyscheme_genesi... 3762 case OP_NEWLINE:
tinyscheme_genesi... 3763 if(is_pair(sc->args)) {
tinyscheme_genesi... 3764 if(car(sc->args)!=sc->outport) {
tinyscheme_genesi... 3765 x=cons(sc,sc->outport,sc->NIL);
tinyscheme_genesi... 3766 s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
tinyscheme_genesi... 3767 sc->outport=car(sc->args);
tinyscheme_genesi... 3768 }
tinyscheme_genesi... 3769 }
tinyscheme_genesi... 3770 putstr(sc, "\n");
tinyscheme_genesi... 3771 s_return(sc,sc->T);
tinyscheme_genesi... 3772
tinyscheme_genesi... 3773 case OP_ERR0:
tinyscheme_genesi... 3774 sc->retcode=-1;
tinyscheme_genesi... 3775 if (!is_string(car(sc->args))) {
tinyscheme_genesi... 3776 sc->args=cons(sc,mk_string(sc," -- "),sc->args);
tinyscheme_genesi... 3777 setimmutable(car(sc->args));
tinyscheme_genesi... 3778 }
tinyscheme_genesi... 3779 putstr(sc, "Error: ");
tinyscheme_genesi... 3780 putstr(sc, strvalue(car(sc->args)));
tinyscheme_genesi... 3781 sc->args = cdr(sc->args);
tinyscheme_genesi... 3782 s_goto(sc,OP_ERR1);
tinyscheme_genesi... 3783
tinyscheme_genesi... 3784 case OP_ERR1:
tinyscheme_genesi... 3785 putstr(sc, " ");
tinyscheme_genesi... 3786 if (sc->args != sc->NIL) {
tinyscheme_genesi... 3787 s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
tinyscheme_genesi... 3788 sc->args = car(sc->args);
tinyscheme_genesi... 3789 sc->print_flag = 1;
tinyscheme_genesi... 3790 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 3791 } else {
tinyscheme_genesi... 3792 putstr(sc, "\n");
tinyscheme_genesi... 3793 if(sc->interactive_repl) {
tinyscheme_genesi... 3794 s_goto(sc,OP_T0LVL);
tinyscheme_genesi... 3795 } else {
tinyscheme_genesi... 3796 return sc->NIL;
tinyscheme_genesi... 3797 }
tinyscheme_genesi... 3798 }
tinyscheme_genesi... 3799
tinyscheme_genesi... 3800 case OP_REVERSE:
tinyscheme_genesi... 3801 s_return(sc,reverse(sc, car(sc->args)));
tinyscheme_genesi... 3802
tinyscheme_genesi... 3803 case OP_LIST_STAR:
tinyscheme_genesi... 3804 s_return(sc,list_star(sc,sc->args));
tinyscheme_genesi... 3805
tinyscheme_genesi... 3806 case OP_APPEND:
tinyscheme_genesi... 3807 x = sc->NIL;
tinyscheme_genesi... 3808 y = sc->args;
tinyscheme_genesi... 3809 if (y == x) {
tinyscheme_genesi... 3810 s_return(sc, x);
tinyscheme_genesi... 3811 }
tinyscheme_genesi... 3812
tinyscheme_genesi... 3813
tinyscheme_genesi... 3814
tinyscheme_genesi... 3815 while (cdr(y) != sc->NIL) {
tinyscheme_genesi... 3816 x = revappend(sc, x, car(y));
tinyscheme_genesi... 3817 y = cdr(y);
tinyscheme_genesi... 3818 if (x == sc->F) {
tinyscheme_genesi... 3819 Error_0(sc, "non-list argument to append");
tinyscheme_genesi... 3820 }
tinyscheme_genesi... 3821 }
tinyscheme_genesi... 3822
tinyscheme_genesi... 3823 s_return(sc, reverse_in_place(sc, car(y), x));
tinyscheme_genesi... 3824
tinyscheme_genesi... 3825 #if USE_PLIST
tinyscheme_genesi... 3826 case OP_PUT:
tinyscheme_genesi... 3827 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
tinyscheme_genesi... 3828 Error_0(sc,"illegal use of put");
tinyscheme_genesi... 3829 }
tinyscheme_genesi... 3830 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3831 if (caar(x) == y) {
tinyscheme_genesi... 3832 break;
tinyscheme_genesi... 3833 }
tinyscheme_genesi... 3834 }
tinyscheme_genesi... 3835 if (x != sc->NIL)
tinyscheme_genesi... 3836 cdar(x) = caddr(sc->args);
tinyscheme_genesi... 3837 else
tinyscheme_genesi... 3838 symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
tinyscheme_genesi... 3839 symprop(car(sc->args)));
tinyscheme_genesi... 3840 s_return(sc,sc->T);
tinyscheme_genesi... 3841
tinyscheme_genesi... 3842 case OP_GET:
tinyscheme_genesi... 3843 if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
tinyscheme_genesi... 3844 Error_0(sc,"illegal use of get");
tinyscheme_genesi... 3845 }
tinyscheme_genesi... 3846 for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
tinyscheme_genesi... 3847 if (caar(x) == y) {
tinyscheme_genesi... 3848 break;
tinyscheme_genesi... 3849 }
tinyscheme_genesi... 3850 }
tinyscheme_genesi... 3851 if (x != sc->NIL) {
tinyscheme_genesi... 3852 s_return(sc,cdar(x));
tinyscheme_genesi... 3853 } else {
tinyscheme_genesi... 3854 s_return(sc,sc->NIL);
tinyscheme_genesi... 3855 }
tinyscheme_genesi... 3856 #endif /* USE_PLIST */
tinyscheme_genesi... 3857 case OP_QUIT:
tinyscheme_genesi... 3858 if(is_pair(sc->args)) {
tinyscheme_genesi... 3859 sc->retcode=ivalue(car(sc->args));
tinyscheme_genesi... 3860 }
tinyscheme_genesi... 3861 return (sc->NIL);
tinyscheme_genesi... 3862
tinyscheme_genesi... 3863 case OP_GC:
tinyscheme_genesi... 3864 gc(sc, sc->NIL, sc->NIL);
tinyscheme_genesi... 3865 s_return(sc,sc->T);
tinyscheme_genesi... 3866
tinyscheme_genesi... 3867 case OP_GCVERB:
tinyscheme_genesi... 3868 { int was = sc->gc_verbose;
tinyscheme_genesi... 3869
tinyscheme_genesi... 3870 sc->gc_verbose = (car(sc->args) != sc->F);
tinyscheme_genesi... 3871 s_retbool(was);
tinyscheme_genesi... 3872 }
tinyscheme_genesi... 3873
tinyscheme_genesi... 3874 case OP_NEWSEGMENT:
tinyscheme_genesi... 3875 if (!is_pair(sc->args) || !is_number(car(sc->args))) {
tinyscheme_genesi... 3876 Error_0(sc,"new-segment: argument must be a number");
tinyscheme_genesi... 3877 }
tinyscheme_genesi... 3878 alloc_cellseg(sc, (int) ivalue(car(sc->args)));
tinyscheme_genesi... 3879 s_return(sc,sc->T);
tinyscheme_genesi... 3880
tinyscheme_genesi... 3881 case OP_OBLIST:
tinyscheme_genesi... 3882 s_return(sc, oblist_all_symbols(sc));
tinyscheme_genesi... 3883
tinyscheme_genesi... 3884 case OP_CURR_INPORT:
tinyscheme_genesi... 3885 s_return(sc,sc->inport);
tinyscheme_genesi... 3886
tinyscheme_genesi... 3887 case OP_CURR_OUTPORT:
tinyscheme_genesi... 3888 s_return(sc,sc->outport);
tinyscheme_genesi... 3889
tinyscheme_genesi... 3890 case OP_OPEN_INFILE:
tinyscheme_genesi... 3891 case OP_OPEN_OUTFILE:
tinyscheme_genesi... 3892 case OP_OPEN_INOUTFILE: {
tinyscheme_genesi... 3893 int prop=0;
tinyscheme_genesi... 3894 pointer p;
tinyscheme_genesi... 3895 switch(op) {
tinyscheme_genesi... 3896 case OP_OPEN_INFILE: prop=port_input; break;
tinyscheme_genesi... 3897 case OP_OPEN_OUTFILE: prop=port_output; break;
tinyscheme_genesi... 3898 case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
tinyscheme_genesi... 3899 }
tinyscheme_genesi... 3900 p=port_from_filename(sc,strvalue(car(sc->args)),prop);
tinyscheme_genesi... 3901 if(p==sc->NIL) {
tinyscheme_genesi... 3902 s_return(sc,sc->F);
tinyscheme_genesi... 3903 }
tinyscheme_genesi... 3904 s_return(sc,p);
tinyscheme_genesi... 3905 }
tinyscheme_genesi... 3906
tinyscheme_genesi... 3907 #if USE_STRING_PORTS
tinyscheme_genesi... 3908 case OP_OPEN_INSTRING:
tinyscheme_genesi... 3909 case OP_OPEN_INOUTSTRING: {
tinyscheme_genesi... 3910 int prop=0;
tinyscheme_genesi... 3911 pointer p;
tinyscheme_genesi... 3912 switch(op) {
tinyscheme_genesi... 3913 case OP_OPEN_INSTRING: prop=port_input; break;
tinyscheme_genesi... 3914 case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
tinyscheme_genesi... 3915 }
tinyscheme_genesi... 3916 p=port_from_string(sc, strvalue(car(sc->args)),
tinyscheme_genesi... 3917 strvalue(car(sc->args))+strlength(car(sc->args)), prop);
tinyscheme_genesi... 3918 if(p==sc->NIL) {
tinyscheme_genesi... 3919 s_return(sc,sc->F);
tinyscheme_genesi... 3920 }
tinyscheme_genesi... 3921 s_return(sc,p);
tinyscheme_genesi... 3922 }
tinyscheme_genesi... 3923 case OP_OPEN_OUTSTRING: {
tinyscheme_genesi... 3924 pointer p;
tinyscheme_genesi... 3925 if(car(sc->args)==sc->NIL) {
tinyscheme_genesi... 3926 p=port_from_scratch(sc);
tinyscheme_genesi... 3927 if(p==sc->NIL) {
tinyscheme_genesi... 3928 s_return(sc,sc->F);
tinyscheme_genesi... 3929 }
tinyscheme_genesi... 3930 } else {
tinyscheme_genesi... 3931 p=port_from_string(sc, strvalue(car(sc->args)),
tinyscheme_genesi... 3932 strvalue(car(sc->args))+strlength(car(sc->args)),
tinyscheme_genesi... 3933 port_output);
tinyscheme_genesi... 3934 if(p==sc->NIL) {
tinyscheme_genesi... 3935 s_return(sc,sc->F);
tinyscheme_genesi... 3936 }
tinyscheme_genesi... 3937 }
tinyscheme_genesi... 3938 s_return(sc,p);
tinyscheme_genesi... 3939 }
tinyscheme_genesi... 3940 case OP_GET_OUTSTRING: {
tinyscheme_genesi... 3941 port *p;
tinyscheme_genesi... 3942
tinyscheme_genesi... 3943 if ((p=car(sc->args)->_object._port)->kind&port_string) {
tinyscheme_genesi... 3944 off_t size;
tinyscheme_genesi... 3945 char *str;
tinyscheme_genesi... 3946
tinyscheme_genesi... 3947 size=p->rep.string.curr-p->rep.string.start+1;
tinyscheme_genesi... 3948 str=sc->malloc(size);
tinyscheme_genesi... 3949 if(str != NULL) {
tinyscheme_genesi... 3950 pointer s;
tinyscheme_genesi... 3951
tinyscheme_genesi... 3952 memcpy(str,p->rep.string.start,size-1);
tinyscheme_genesi... 3953 str[size-1]='\0';
tinyscheme_genesi... 3954 s=mk_string(sc,str);
tinyscheme_genesi... 3955 sc->free(str);
tinyscheme_genesi... 3956 s_return(sc,s);
tinyscheme_genesi... 3957 }
tinyscheme_genesi... 3958 }
tinyscheme_genesi... 3959 s_return(sc,sc->F);
tinyscheme_genesi... 3960 }
tinyscheme_genesi... 3961 #endif
tinyscheme_genesi... 3962
tinyscheme_genesi... 3963 case OP_CLOSE_INPORT:
tinyscheme_genesi... 3964 port_close(sc,car(sc->args),port_input);
tinyscheme_genesi... 3965 s_return(sc,sc->T);
tinyscheme_genesi... 3966
tinyscheme_genesi... 3967 case OP_CLOSE_OUTPORT:
tinyscheme_genesi... 3968 port_close(sc,car(sc->args),port_output);
tinyscheme_genesi... 3969 s_return(sc,sc->T);
tinyscheme_genesi... 3970
tinyscheme_genesi... 3971 case OP_INT_ENV:
tinyscheme_genesi... 3972 s_return(sc,sc->global_env);
tinyscheme_genesi... 3973
tinyscheme_genesi... 3974 case OP_CURR_ENV:
tinyscheme_genesi... 3975 s_return(sc,sc->envir);
tinyscheme_genesi... 3976
tinyscheme_genesi... 3977 }
tinyscheme_genesi... 3978 return sc->T;
tinyscheme_genesi... 3979 }
tinyscheme_genesi... 3980
tinyscheme_genesi... 3981 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 3982 pointer x;
tinyscheme_genesi... 3983
tinyscheme_genesi... 3984 if(sc->nesting!=0) {
tinyscheme_genesi... 3985 int n=sc->nesting;
tinyscheme_genesi... 3986 sc->nesting=0;
tinyscheme_genesi... 3987 sc->retcode=-1;
tinyscheme_genesi... 3988 Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
tinyscheme_genesi... 3989 }
tinyscheme_genesi... 3990
tinyscheme_genesi... 3991 switch (op) {
tinyscheme_genesi... 3992
tinyscheme_genesi... 3993 case OP_READ:
tinyscheme_genesi... 3994 if(!is_pair(sc->args)) {
tinyscheme_genesi... 3995 s_goto(sc,OP_READ_INTERNAL);
tinyscheme_genesi... 3996 }
tinyscheme_genesi... 3997 if(!is_inport(car(sc->args))) {
tinyscheme_genesi... 3998 Error_1(sc,"read: not an input port:",car(sc->args));
tinyscheme_genesi... 3999 }
tinyscheme_genesi... 4000 if(car(sc->args)==sc->inport) {
tinyscheme_genesi... 4001 s_goto(sc,OP_READ_INTERNAL);
tinyscheme_genesi... 4002 }
tinyscheme_genesi... 4003 x=sc->inport;
tinyscheme_genesi... 4004 sc->inport=car(sc->args);
tinyscheme_genesi... 4005 x=cons(sc,x,sc->NIL);
tinyscheme_genesi... 4006 s_save(sc,OP_SET_INPORT, x, sc->NIL);
tinyscheme_genesi... 4007 s_goto(sc,OP_READ_INTERNAL);
tinyscheme_genesi... 4008
tinyscheme_genesi... 4009 case OP_READ_CHAR:
tinyscheme_genesi... 4010 case OP_PEEK_CHAR: {
tinyscheme_genesi... 4011 int c;
tinyscheme_genesi... 4012 if(is_pair(sc->args)) {
tinyscheme_genesi... 4013 if(car(sc->args)!=sc->inport) {
tinyscheme_genesi... 4014 x=sc->inport;
tinyscheme_genesi... 4015 x=cons(sc,x,sc->NIL);
tinyscheme_genesi... 4016 s_save(sc,OP_SET_INPORT, x, sc->NIL);
tinyscheme_genesi... 4017 sc->inport=car(sc->args);
tinyscheme_genesi... 4018 }
tinyscheme_genesi... 4019 }
tinyscheme_genesi... 4020 c=inchar(sc);
tinyscheme_genesi... 4021 if(c==EOF) {
tinyscheme_genesi... 4022 s_return(sc,sc->EOF_OBJ);
tinyscheme_genesi... 4023 }
tinyscheme_genesi... 4024 if(sc->op==OP_PEEK_CHAR) {
tinyscheme_genesi... 4025 backchar(sc,c);
tinyscheme_genesi... 4026 }
tinyscheme_genesi... 4027 s_return(sc,mk_character(sc,c));
tinyscheme_genesi... 4028 }
tinyscheme_genesi... 4029
tinyscheme_genesi... 4030 case OP_CHAR_READY: {
tinyscheme_genesi... 4031 pointer p=sc->inport;
tinyscheme_genesi... 4032 int res;
tinyscheme_genesi... 4033 if(is_pair(sc->args)) {
tinyscheme_genesi... 4034 p=car(sc->args);
tinyscheme_genesi... 4035 }
tinyscheme_genesi... 4036 res=p->_object._port->kind&port_string;
tinyscheme_genesi... 4037 s_retbool(res);
tinyscheme_genesi... 4038 }
tinyscheme_genesi... 4039
tinyscheme_genesi... 4040 case OP_SET_INPORT:
tinyscheme_genesi... 4041 sc->inport=car(sc->args);
tinyscheme_genesi... 4042 s_return(sc,sc->value);
tinyscheme_genesi... 4043
tinyscheme_genesi... 4044 case OP_SET_OUTPORT:
tinyscheme_genesi... 4045 sc->outport=car(sc->args);
tinyscheme_genesi... 4046 s_return(sc,sc->value);
tinyscheme_genesi... 4047
tinyscheme_genesi... 4048 case OP_RDSEXPR:
tinyscheme_genesi... 4049 switch (sc->tok) {
tinyscheme_genesi... 4050 case TOK_EOF:
tinyscheme_genesi... 4051 s_return(sc,sc->EOF_OBJ);
tinyscheme_genesi... 4052
tinyscheme_genesi... 4053
tinyscheme_genesi... 4054 * Commented out because we now skip comments in the scanner
tinyscheme_genesi... 4055 *
tinyscheme_genesi... 4056 case TOK_COMMENT: {
tinyscheme_genesi... 4057 int c;
tinyscheme_genesi... 4058 while ((c=inchar(sc)) != '\n' && c!=EOF)
tinyscheme_genesi... 4059 ;
tinyscheme_genesi... 4060 sc->tok = token(sc);
tinyscheme_genesi... 4061 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4062 }
tinyscheme_genesi... 4063 */
tinyscheme_genesi... 4064 case TOK_VEC:
tinyscheme_genesi... 4065 s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
tinyscheme_genesi... 4066
tinyscheme_genesi... 4067 case TOK_LPAREN:
tinyscheme_genesi... 4068 sc->tok = token(sc);
tinyscheme_genesi... 4069 if (sc->tok == TOK_RPAREN) {
tinyscheme_genesi... 4070 s_return(sc,sc->NIL);
tinyscheme_genesi... 4071 } else if (sc->tok == TOK_DOT) {
tinyscheme_genesi... 4072 Error_0(sc,"syntax error: illegal dot expression");
tinyscheme_genesi... 4073 } else {
tinyscheme_genesi... 4074 sc->nesting_stack[sc->file_i]++;
tinyscheme_genesi... 4075 s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
tinyscheme_genesi... 4076 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4077 }
tinyscheme_genesi... 4078 case TOK_QUOTE:
tinyscheme_genesi... 4079 s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
tinyscheme_genesi... 4080 sc->tok = token(sc);
tinyscheme_genesi... 4081 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4082 case TOK_BQUOTE:
tinyscheme_genesi... 4083 sc->tok = token(sc);
tinyscheme_genesi... 4084 if(sc->tok==TOK_VEC) {
tinyscheme_genesi... 4085 s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
tinyscheme_genesi... 4086 sc->tok=TOK_LPAREN;
tinyscheme_genesi... 4087 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4088 } else {
tinyscheme_genesi... 4089 s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
tinyscheme_genesi... 4090 }
tinyscheme_genesi... 4091 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4092 case TOK_COMMA:
tinyscheme_genesi... 4093 s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
tinyscheme_genesi... 4094 sc->tok = token(sc);
tinyscheme_genesi... 4095 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4096 case TOK_ATMARK:
tinyscheme_genesi... 4097 s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
tinyscheme_genesi... 4098 sc->tok = token(sc);
tinyscheme_genesi... 4099 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4100 case TOK_ATOM:
tinyscheme_genesi... 4101 s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
tinyscheme_genesi... 4102 case TOK_DQUOTE:
tinyscheme_genesi... 4103 x=readstrexp(sc);
tinyscheme_genesi... 4104 if(x==sc->F) {
tinyscheme_genesi... 4105 Error_0(sc,"Error reading string");
tinyscheme_genesi... 4106 }
tinyscheme_genesi... 4107 setimmutable(x);
tinyscheme_genesi... 4108 s_return(sc,x);
tinyscheme_genesi... 4109 case TOK_SHARP: {
tinyscheme_genesi... 4110 pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
tinyscheme_genesi... 4111 if(f==sc->NIL) {
tinyscheme_genesi... 4112 Error_0(sc,"undefined sharp expression");
tinyscheme_genesi... 4113 } else {
tinyscheme_genesi... 4114 sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
tinyscheme_genesi... 4115 s_goto(sc,OP_EVAL);
tinyscheme_genesi... 4116 }
tinyscheme_genesi... 4117 }
tinyscheme_genesi... 4118 case TOK_SHARP_CONST:
tinyscheme_genesi... 4119 if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
tinyscheme_genesi... 4120 Error_0(sc,"undefined sharp expression");
tinyscheme_genesi... 4121 } else {
tinyscheme_genesi... 4122 s_return(sc,x);
tinyscheme_genesi... 4123 }
tinyscheme_genesi... 4124 default:
tinyscheme_genesi... 4125 Error_0(sc,"syntax error: illegal token");
tinyscheme_genesi... 4126 }
tinyscheme_genesi... 4127 break;
tinyscheme_genesi... 4128
tinyscheme_genesi... 4129 case OP_RDLIST: {
tinyscheme_genesi... 4130 sc->args = cons(sc, sc->value, sc->args);
tinyscheme_genesi... 4131 sc->tok = token(sc);
tinyscheme_genesi... 4132
tinyscheme_genesi... 4133 while (sc->tok == TOK_COMMENT) {
tinyscheme_genesi... 4134 int c;
tinyscheme_genesi... 4135 while ((c=inchar(sc)) != '\n' && c!=EOF)
tinyscheme_genesi... 4136 ;
tinyscheme_genesi... 4137 sc->tok = token(sc);
tinyscheme_genesi... 4138 }
tinyscheme_genesi... 4139 */
tinyscheme_genesi... 4140 if (sc->tok == TOK_EOF)
tinyscheme_genesi... 4141 { s_return(sc,sc->EOF_OBJ); }
tinyscheme_genesi... 4142 else if (sc->tok == TOK_RPAREN) {
tinyscheme_genesi... 4143 int c = inchar(sc);
tinyscheme_genesi... 4144 if (c != '\n')
tinyscheme_genesi... 4145 backchar(sc,c);
tinyscheme_genesi... 4146 #if SHOW_ERROR_LINE
tinyscheme_genesi... 4147 else if (sc->load_stack[sc->file_i].kind & port_file)
tinyscheme_genesi... 4148 sc->load_stack[sc->file_i].rep.stdio.curr_line++;
tinyscheme_genesi... 4149 #endif
tinyscheme_genesi... 4150 sc->nesting_stack[sc->file_i]--;
tinyscheme_genesi... 4151 s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
tinyscheme_genesi... 4152 } else if (sc->tok == TOK_DOT) {
tinyscheme_genesi... 4153 s_save(sc,OP_RDDOT, sc->args, sc->NIL);
tinyscheme_genesi... 4154 sc->tok = token(sc);
tinyscheme_genesi... 4155 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4156 } else {
tinyscheme_genesi... 4157 s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
tinyscheme_genesi... 4158 s_goto(sc,OP_RDSEXPR);
tinyscheme_genesi... 4159 }
tinyscheme_genesi... 4160 }
tinyscheme_genesi... 4161
tinyscheme_genesi... 4162 case OP_RDDOT:
tinyscheme_genesi... 4163 if (token(sc) != TOK_RPAREN) {
tinyscheme_genesi... 4164 Error_0(sc,"syntax error: illegal dot expression");
tinyscheme_genesi... 4165 } else {
tinyscheme_genesi... 4166 sc->nesting_stack[sc->file_i]--;
tinyscheme_genesi... 4167 s_return(sc,reverse_in_place(sc, sc->value, sc->args));
tinyscheme_genesi... 4168 }
tinyscheme_genesi... 4169
tinyscheme_genesi... 4170 case OP_RDQUOTE:
tinyscheme_genesi... 4171 s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
tinyscheme_genesi... 4172
tinyscheme_genesi... 4173 case OP_RDQQUOTE:
tinyscheme_genesi... 4174 s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
tinyscheme_genesi... 4175
tinyscheme_genesi... 4176 case OP_RDQQUOTEVEC:
tinyscheme_genesi... 4177 s_return(sc,cons(sc, mk_symbol(sc,"apply"),
tinyscheme_genesi... 4178 cons(sc, mk_symbol(sc,"vector"),
tinyscheme_genesi... 4179 cons(sc,cons(sc, sc->QQUOTE,
tinyscheme_genesi... 4180 cons(sc,sc->value,sc->NIL)),
tinyscheme_genesi... 4181 sc->NIL))));
tinyscheme_genesi... 4182
tinyscheme_genesi... 4183 case OP_RDUNQUOTE:
tinyscheme_genesi... 4184 s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
tinyscheme_genesi... 4185
tinyscheme_genesi... 4186 case OP_RDUQTSP:
tinyscheme_genesi... 4187 s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
tinyscheme_genesi... 4188
tinyscheme_genesi... 4189 case OP_RDVEC:
tinyscheme_genesi... 4190
tinyscheme_genesi... 4191 s_goto(sc,OP_EVAL); Cannot be quoted*/
tinyscheme_genesi... 4192
tinyscheme_genesi... 4193 s_return(sc,x); Cannot be part of pairs*/
tinyscheme_genesi... 4194
tinyscheme_genesi... 4195 sc->args=sc->value;
tinyscheme_genesi... 4196 s_goto(sc,OP_APPLY);*/
tinyscheme_genesi... 4197 sc->args=sc->value;
tinyscheme_genesi... 4198 s_goto(sc,OP_VECTOR);
tinyscheme_genesi... 4199
tinyscheme_genesi... 4200
tinyscheme_genesi... 4201 case OP_P0LIST:
tinyscheme_genesi... 4202 if(is_vector(sc->args)) {
tinyscheme_genesi... 4203 putstr(sc,"#(");
tinyscheme_genesi... 4204 sc->args=cons(sc,sc->args,mk_integer(sc,0));
tinyscheme_genesi... 4205 s_goto(sc,OP_PVECFROM);
tinyscheme_genesi... 4206 } else if(is_environment(sc->args)) {
tinyscheme_genesi... 4207 putstr(sc,"#<ENVIRONMENT>");
tinyscheme_genesi... 4208 s_return(sc,sc->T);
tinyscheme_genesi... 4209 } else if (!is_pair(sc->args)) {
tinyscheme_genesi... 4210 printatom(sc, sc->args, sc->print_flag);
tinyscheme_genesi... 4211 s_return(sc,sc->T);
tinyscheme_genesi... 4212 } else if (car(sc->args) == sc->QUOTE && 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->QQUOTE && 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->UNQUOTE && 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 if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
tinyscheme_genesi... 4225 putstr(sc, ",@");
tinyscheme_genesi... 4226 sc->args = cadr(sc->args);
tinyscheme_genesi... 4227 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 4228 } else {
tinyscheme_genesi... 4229 putstr(sc, "(");
tinyscheme_genesi... 4230 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
tinyscheme_genesi... 4231 sc->args = car(sc->args);
tinyscheme_genesi... 4232 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 4233 }
tinyscheme_genesi... 4234
tinyscheme_genesi... 4235 case OP_P1LIST:
tinyscheme_genesi... 4236 if (is_pair(sc->args)) {
tinyscheme_genesi... 4237 s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
tinyscheme_genesi... 4238 putstr(sc, " ");
tinyscheme_genesi... 4239 sc->args = car(sc->args);
tinyscheme_genesi... 4240 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 4241 } else if(is_vector(sc->args)) {
tinyscheme_genesi... 4242 s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
tinyscheme_genesi... 4243 putstr(sc, " . ");
tinyscheme_genesi... 4244 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 4245 } else {
tinyscheme_genesi... 4246 if (sc->args != sc->NIL) {
tinyscheme_genesi... 4247 putstr(sc, " . ");
tinyscheme_genesi... 4248 printatom(sc, sc->args, sc->print_flag);
tinyscheme_genesi... 4249 }
tinyscheme_genesi... 4250 putstr(sc, ")");
tinyscheme_genesi... 4251 s_return(sc,sc->T);
tinyscheme_genesi... 4252 }
tinyscheme_genesi... 4253 case OP_PVECFROM: {
tinyscheme_genesi... 4254 int i=ivalue_unchecked(cdr(sc->args));
tinyscheme_genesi... 4255 pointer vec=car(sc->args);
tinyscheme_genesi... 4256 int len=ivalue_unchecked(vec);
tinyscheme_genesi... 4257 if(i==len) {
tinyscheme_genesi... 4258 putstr(sc,")");
tinyscheme_genesi... 4259 s_return(sc,sc->T);
tinyscheme_genesi... 4260 } else {
tinyscheme_genesi... 4261 pointer elem=vector_elem(vec,i);
tinyscheme_genesi... 4262 ivalue_unchecked(cdr(sc->args))=i+1;
tinyscheme_genesi... 4263 s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
tinyscheme_genesi... 4264 sc->args=elem;
tinyscheme_genesi... 4265 if (i > 0)
tinyscheme_genesi... 4266 putstr(sc," ");
tinyscheme_genesi... 4267 s_goto(sc,OP_P0LIST);
tinyscheme_genesi... 4268 }
tinyscheme_genesi... 4269 }
tinyscheme_genesi... 4270
tinyscheme_genesi... 4271 default:
tinyscheme_genesi... 4272 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 4273 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 4274
tinyscheme_genesi... 4275 }
tinyscheme_genesi... 4276 return sc->T;
tinyscheme_genesi... 4277 }
tinyscheme_genesi... 4278
tinyscheme_genesi... 4279 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 4280 pointer x, y;
tinyscheme_genesi... 4281 long v;
tinyscheme_genesi... 4282
tinyscheme_genesi... 4283 switch (op) {
tinyscheme_genesi... 4284 case OP_LIST_LENGTH:
tinyscheme_genesi... 4285 v=list_length(sc,car(sc->args));
tinyscheme_genesi... 4286 if(v<0) {
tinyscheme_genesi... 4287 Error_1(sc,"length: not a list:",car(sc->args));
tinyscheme_genesi... 4288 }
tinyscheme_genesi... 4289 s_return(sc,mk_integer(sc, v));
tinyscheme_genesi... 4290
tinyscheme_genesi... 4291 case OP_ASSQ:
tinyscheme_genesi... 4292 x = car(sc->args);
tinyscheme_genesi... 4293 for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
tinyscheme_genesi... 4294 if (!is_pair(car(y))) {
tinyscheme_genesi... 4295 Error_0(sc,"unable to handle non pair element");
tinyscheme_genesi... 4296 }
tinyscheme_genesi... 4297 if (x == caar(y))
tinyscheme_genesi... 4298 break;
tinyscheme_genesi... 4299 }
tinyscheme_genesi... 4300 if (is_pair(y)) {
tinyscheme_genesi... 4301 s_return(sc,car(y));
tinyscheme_genesi... 4302 } else {
tinyscheme_genesi... 4303 s_return(sc,sc->F);
tinyscheme_genesi... 4304 }
tinyscheme_genesi... 4305
tinyscheme_genesi... 4306
tinyscheme_genesi... 4307 case OP_GET_CLOSURE:
tinyscheme_genesi... 4308 sc->args = car(sc->args);
tinyscheme_genesi... 4309 if (sc->args == sc->NIL) {
tinyscheme_genesi... 4310 s_return(sc,sc->F);
tinyscheme_genesi... 4311 } else if (is_closure(sc->args)) {
tinyscheme_genesi... 4312 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
tinyscheme_genesi... 4313 } else if (is_macro(sc->args)) {
tinyscheme_genesi... 4314 s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
tinyscheme_genesi... 4315 } else {
tinyscheme_genesi... 4316 s_return(sc,sc->F);
tinyscheme_genesi... 4317 }
tinyscheme_genesi... 4318 case OP_CLOSUREP:
tinyscheme_genesi... 4319
tinyscheme_genesi... 4320 * Note, macro object is also a closure.
tinyscheme_genesi... 4321 * Therefore, (closure? <#MACRO>) ==> #t
tinyscheme_genesi... 4322 */
tinyscheme_genesi... 4323 s_retbool(is_closure(car(sc->args)));
tinyscheme_genesi... 4324 case OP_MACROP:
tinyscheme_genesi... 4325 s_retbool(is_macro(car(sc->args)));
tinyscheme_genesi... 4326 default:
tinyscheme_genesi... 4327 snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
tinyscheme_genesi... 4328 Error_0(sc,sc->strbuff);
tinyscheme_genesi... 4329 }
tinyscheme_genesi... 4330 return sc->T;
tinyscheme_genesi... 4331 }
tinyscheme_genesi... 4332
tinyscheme_genesi... 4333 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
tinyscheme_genesi... 4334
tinyscheme_genesi... 4335 typedef int (*test_predicate)(pointer);
tinyscheme_genesi... 4336 static int is_any(pointer p) { return 1;}
tinyscheme_genesi... 4337
tinyscheme_genesi... 4338 static int is_nonneg(pointer p) {
tinyscheme_genesi... 4339 return ivalue(p)>=0 && is_integer(p);
tinyscheme_genesi... 4340 }
tinyscheme_genesi... 4341
tinyscheme_genesi... 4342
tinyscheme_genesi... 4343 static struct {
tinyscheme_genesi... 4344 test_predicate fct;
tinyscheme_genesi... 4345 const char *kind;
tinyscheme_genesi... 4346 } tests[]={
tinyscheme_genesi... 4347 {0,0},
tinyscheme_genesi... 4348 {is_any, 0},
tinyscheme_genesi... 4349 {is_string, "string"},
tinyscheme_genesi... 4350 {is_symbol, "symbol"},
tinyscheme_genesi... 4351 {is_port, "port"},
tinyscheme_genesi... 4352 {is_inport,"input port"},
tinyscheme_genesi... 4353 {is_outport,"output port"},
tinyscheme_genesi... 4354 {is_environment, "environment"},
tinyscheme_genesi... 4355 {is_pair, "pair"},
tinyscheme_genesi... 4356 {0, "pair or '()"},
tinyscheme_genesi... 4357 {is_character, "character"},
tinyscheme_genesi... 4358 {is_vector, "vector"},
tinyscheme_genesi... 4359 {is_number, "number"},
tinyscheme_genesi... 4360 {is_integer, "integer"},
tinyscheme_genesi... 4361 {is_nonneg, "non-negative integer"}
tinyscheme_genesi... 4362 };
tinyscheme_genesi... 4363
tinyscheme_genesi... 4364 #define TST_NONE 0
tinyscheme_genesi... 4365 #define TST_ANY "\001"
tinyscheme_genesi... 4366 #define TST_STRING "\002"
tinyscheme_genesi... 4367 #define TST_SYMBOL "\003"
tinyscheme_genesi... 4368 #define TST_PORT "\004"
tinyscheme_genesi... 4369 #define TST_INPORT "\005"
tinyscheme_genesi... 4370 #define TST_OUTPORT "\006"
tinyscheme_genesi... 4371 #define TST_ENVIRONMENT "\007"
tinyscheme_genesi... 4372 #define TST_PAIR "\010"
tinyscheme_genesi... 4373 #define TST_LIST "\011"
tinyscheme_genesi... 4374 #define TST_CHAR "\012"
tinyscheme_genesi... 4375 #define TST_VECTOR "\013"
tinyscheme_genesi... 4376 #define TST_NUMBER "\014"
tinyscheme_genesi... 4377 #define TST_INTEGER "\015"
tinyscheme_genesi... 4378 #define TST_NATURAL "\016"
tinyscheme_genesi... 4379
tinyscheme_genesi... 4380 typedef struct {
tinyscheme_genesi... 4381 dispatch_func func;
tinyscheme_genesi... 4382 char *name;
tinyscheme_genesi... 4383 int min_arity;
tinyscheme_genesi... 4384 int max_arity;
tinyscheme_genesi... 4385 char *arg_tests_encoding;
tinyscheme_genesi... 4386 } op_code_info;
tinyscheme_genesi... 4387
tinyscheme_genesi... 4388 #define INF_ARG 0xffff
tinyscheme_genesi... 4389
tinyscheme_genesi... 4390 static op_code_info dispatch_table[]= {
tinyscheme_genesi... 4391 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
tinyscheme_genesi... 4392 #include "opdefines.h"
tinyscheme_genesi... 4393 { 0 }
tinyscheme_genesi... 4394 };
tinyscheme_genesi... 4395
tinyscheme_genesi... 4396 static const char *procname(pointer x) {
tinyscheme_genesi... 4397 int n=procnum(x);
tinyscheme_genesi... 4398 const char *name=dispatch_table[n].name;
tinyscheme_genesi... 4399 if(name==0) {
tinyscheme_genesi... 4400 name="ILLEGAL!";
tinyscheme_genesi... 4401 }
tinyscheme_genesi... 4402 return name;
tinyscheme_genesi... 4403 }
tinyscheme_genesi... 4404
tinyscheme_genesi... 4405
tinyscheme_genesi... 4406 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 4407 sc->op = op;
tinyscheme_genesi... 4408 for (;;) {
tinyscheme_genesi... 4409 op_code_info *pcd=dispatch_table+sc->op;
tinyscheme_genesi... 4410 if (pcd->name!=0) {
tinyscheme_genesi... 4411 char msg[STRBUFFSIZE];
tinyscheme_genesi... 4412 int ok=1;
tinyscheme_genesi... 4413 int n=list_length(sc,sc->args);
tinyscheme_genesi... 4414
tinyscheme_genesi... 4415
tinyscheme_genesi... 4416 if(n<pcd->min_arity) {
tinyscheme_genesi... 4417 ok=0;
tinyscheme_genesi... 4418 snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
tinyscheme_genesi... 4419 pcd->name,
tinyscheme_genesi... 4420 pcd->min_arity==pcd->max_arity?"":" at least",
tinyscheme_genesi... 4421 pcd->min_arity);
tinyscheme_genesi... 4422 }
tinyscheme_genesi... 4423 if(ok && n>pcd->max_arity) {
tinyscheme_genesi... 4424 ok=0;
tinyscheme_genesi... 4425 snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
tinyscheme_genesi... 4426 pcd->name,
tinyscheme_genesi... 4427 pcd->min_arity==pcd->max_arity?"":" at most",
tinyscheme_genesi... 4428 pcd->max_arity);
tinyscheme_genesi... 4429 }
tinyscheme_genesi... 4430 if(ok) {
tinyscheme_genesi... 4431 if(pcd->arg_tests_encoding!=0) {
tinyscheme_genesi... 4432 int i=0;
tinyscheme_genesi... 4433 int j;
tinyscheme_genesi... 4434 const char *t=pcd->arg_tests_encoding;
tinyscheme_genesi... 4435 pointer arglist=sc->args;
tinyscheme_genesi... 4436 do {
tinyscheme_genesi... 4437 pointer arg=car(arglist);
tinyscheme_genesi... 4438 j=(int)t[0];
tinyscheme_genesi... 4439 if(j==TST_LIST[0]) {
tinyscheme_genesi... 4440 if(arg!=sc->NIL && !is_pair(arg)) break;
tinyscheme_genesi... 4441 } else {
tinyscheme_genesi... 4442 if(!tests[j].fct(arg)) break;
tinyscheme_genesi... 4443 }
tinyscheme_genesi... 4444
tinyscheme_genesi... 4445 if(t[1]!=0) {
tinyscheme_genesi... 4446 t++;
tinyscheme_genesi... 4447 }
tinyscheme_genesi... 4448 arglist=cdr(arglist);
tinyscheme_genesi... 4449 i++;
tinyscheme_genesi... 4450 } while(i<n);
tinyscheme_genesi... 4451 if(i<n) {
tinyscheme_genesi... 4452 ok=0;
tinyscheme_genesi... 4453 snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
tinyscheme_genesi... 4454 pcd->name,
tinyscheme_genesi... 4455 i+1,
tinyscheme_genesi... 4456 tests[j].kind);
tinyscheme_genesi... 4457 }
tinyscheme_genesi... 4458 }
tinyscheme_genesi... 4459 }
tinyscheme_genesi... 4460 if(!ok) {
tinyscheme_genesi... 4461 if(_Error_1(sc,msg,0)==sc->NIL) {
tinyscheme_genesi... 4462 return;
tinyscheme_genesi... 4463 }
tinyscheme_genesi... 4464 pcd=dispatch_table+sc->op;
tinyscheme_genesi... 4465 }
tinyscheme_genesi... 4466 }
tinyscheme_genesi... 4467 ok_to_freely_gc(sc);
tinyscheme_genesi... 4468 if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
tinyscheme_genesi... 4469 return;
tinyscheme_genesi... 4470 }
tinyscheme_genesi... 4471 if(sc->no_memory) {
tinyscheme_genesi... 4472 fprintf(stderr,"No memory!\n");
tinyscheme_genesi... 4473 return;
tinyscheme_genesi... 4474 }
tinyscheme_genesi... 4475 }
tinyscheme_genesi... 4476 }
tinyscheme_genesi... 4477
tinyscheme_genesi... 4478
tinyscheme_genesi... 4479
tinyscheme_genesi... 4480 static void assign_syntax(scheme *sc, char *name) {
tinyscheme_genesi... 4481 pointer x;
tinyscheme_genesi... 4482
tinyscheme_genesi... 4483 x = oblist_add_by_name(sc, name);
tinyscheme_genesi... 4484 typeflag(x) |= T_SYNTAX;
tinyscheme_genesi... 4485 }
tinyscheme_genesi... 4486
tinyscheme_genesi... 4487 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
tinyscheme_genesi... 4488 pointer x, y;
tinyscheme_genesi... 4489
tinyscheme_genesi... 4490 x = mk_symbol(sc, name);
tinyscheme_genesi... 4491 y = mk_proc(sc,op);
tinyscheme_genesi... 4492 new_slot_in_env(sc, x, y);
tinyscheme_genesi... 4493 }
tinyscheme_genesi... 4494
tinyscheme_genesi... 4495 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
tinyscheme_genesi... 4496 pointer y;
tinyscheme_genesi... 4497
tinyscheme_genesi... 4498 y = get_cell(sc, sc->NIL, sc->NIL);
tinyscheme_genesi... 4499 typeflag(y) = (T_PROC | T_ATOM);
tinyscheme_genesi... 4500 ivalue_unchecked(y) = (long) op;
tinyscheme_genesi... 4501 set_num_integer(y);
tinyscheme_genesi... 4502 return y;
tinyscheme_genesi... 4503 }
tinyscheme_genesi... 4504
tinyscheme_genesi... 4505
tinyscheme_genesi... 4506 static int syntaxnum(pointer p) {
tinyscheme_genesi... 4507 const char *s=strvalue(car(p));
tinyscheme_genesi... 4508 switch(strlength(car(p))) {
tinyscheme_genesi... 4509 case 2:
tinyscheme_genesi... 4510 if(s[0]=='i') return OP_IF0;
tinyscheme_genesi... 4511 else return OP_OR0;
tinyscheme_genesi... 4512 case 3:
tinyscheme_genesi... 4513 if(s[0]=='a') return OP_AND0;
tinyscheme_genesi... 4514 else return OP_LET0;
tinyscheme_genesi... 4515 case 4:
tinyscheme_genesi... 4516 switch(s[3]) {
tinyscheme_genesi... 4517 case 'e': return OP_CASE0;
tinyscheme_genesi... 4518 case 'd': return OP_COND0;
tinyscheme_genesi... 4519 case '*': return OP_LET0AST;
tinyscheme_genesi... 4520 default: return OP_SET0;
tinyscheme_genesi... 4521 }
tinyscheme_genesi... 4522 case 5:
tinyscheme_genesi... 4523 switch(s[2]) {
tinyscheme_genesi... 4524 case 'g': return OP_BEGIN;
tinyscheme_genesi... 4525 case 'l': return OP_DELAY;
tinyscheme_genesi... 4526 case 'c': return OP_MACRO0;
tinyscheme_genesi... 4527 default: return OP_QUOTE;
tinyscheme_genesi... 4528 }
tinyscheme_genesi... 4529 case 6:
tinyscheme_genesi... 4530 switch(s[2]) {
tinyscheme_genesi... 4531 case 'm': return OP_LAMBDA;
tinyscheme_genesi... 4532 case 'f': return OP_DEF0;
tinyscheme_genesi... 4533 default: return OP_LET0REC;
tinyscheme_genesi... 4534 }
tinyscheme_genesi... 4535 default:
tinyscheme_genesi... 4536 return OP_C0STREAM;
tinyscheme_genesi... 4537 }
tinyscheme_genesi... 4538 }
tinyscheme_genesi... 4539
tinyscheme_genesi... 4540
tinyscheme_genesi... 4541 #if USE_INTERFACE
tinyscheme_genesi... 4542 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
tinyscheme_genesi... 4543 return cons(sc,a,b);
tinyscheme_genesi... 4544 }
tinyscheme_genesi... 4545 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
tinyscheme_genesi... 4546 return immutable_cons(sc,a,b);
tinyscheme_genesi... 4547 }
tinyscheme_genesi... 4548
tinyscheme_genesi... 4549 static struct scheme_interface vtbl ={
tinyscheme_genesi... 4550 scheme_define,
tinyscheme_genesi... 4551 s_cons,
tinyscheme_genesi... 4552 s_immutable_cons,
tinyscheme_genesi... 4553 reserve_cells,
tinyscheme_genesi... 4554 mk_integer,
tinyscheme_genesi... 4555 mk_real,
tinyscheme_genesi... 4556 mk_symbol,
tinyscheme_genesi... 4557 gensym,
tinyscheme_genesi... 4558 mk_string,
tinyscheme_genesi... 4559 mk_counted_string,
tinyscheme_genesi... 4560 mk_character,
tinyscheme_genesi... 4561 mk_vector,
tinyscheme_genesi... 4562 mk_foreign_func,
tinyscheme_genesi... 4563 putstr,
tinyscheme_genesi... 4564 putcharacter,
tinyscheme_genesi... 4565
tinyscheme_genesi... 4566 is_string,
tinyscheme_genesi... 4567 string_value,
tinyscheme_genesi... 4568 is_number,
tinyscheme_genesi... 4569 nvalue,
tinyscheme_genesi... 4570 ivalue,
tinyscheme_genesi... 4571 rvalue,
tinyscheme_genesi... 4572 is_integer,
tinyscheme_genesi... 4573 is_real,
tinyscheme_genesi... 4574 is_character,
tinyscheme_genesi... 4575 charvalue,
tinyscheme_genesi... 4576 is_list,
tinyscheme_genesi... 4577 is_vector,
tinyscheme_genesi... 4578 list_length,
tinyscheme_genesi... 4579 ivalue,
tinyscheme_genesi... 4580 fill_vector,
tinyscheme_genesi... 4581 vector_elem,
tinyscheme_genesi... 4582 set_vector_elem,
tinyscheme_genesi... 4583 is_port,
tinyscheme_genesi... 4584 is_pair,
tinyscheme_genesi... 4585 pair_car,
tinyscheme_genesi... 4586 pair_cdr,
tinyscheme_genesi... 4587 set_car,
tinyscheme_genesi... 4588 set_cdr,
tinyscheme_genesi... 4589
tinyscheme_genesi... 4590 is_symbol,
tinyscheme_genesi... 4591 symname,
tinyscheme_genesi... 4592
tinyscheme_genesi... 4593 is_syntax,
tinyscheme_genesi... 4594 is_proc,
tinyscheme_genesi... 4595 is_foreign,
tinyscheme_genesi... 4596 syntaxname,
tinyscheme_genesi... 4597 is_closure,
tinyscheme_genesi... 4598 is_macro,
tinyscheme_genesi... 4599 closure_code,
tinyscheme_genesi... 4600 closure_env,
tinyscheme_genesi... 4601
tinyscheme_genesi... 4602 is_continuation,
tinyscheme_genesi... 4603 is_promise,
tinyscheme_genesi... 4604 is_environment,
tinyscheme_genesi... 4605 is_immutable,
tinyscheme_genesi... 4606 setimmutable,
tinyscheme_genesi... 4607
tinyscheme_genesi... 4608 scheme_load_file,
tinyscheme_genesi... 4609 scheme_load_string
tinyscheme_genesi... 4610 };
tinyscheme_genesi... 4611 #endif
tinyscheme_genesi... 4612
tinyscheme_genesi... 4613 scheme *scheme_init_new() {
tinyscheme_genesi... 4614 scheme *sc=(scheme*)malloc(sizeof(scheme));
tinyscheme_genesi... 4615 if(!scheme_init(sc)) {
tinyscheme_genesi... 4616 free(sc);
tinyscheme_genesi... 4617 return 0;
tinyscheme_genesi... 4618 } else {
tinyscheme_genesi... 4619 return sc;
tinyscheme_genesi... 4620 }
tinyscheme_genesi... 4621 }
tinyscheme_genesi... 4622
tinyscheme_genesi... 4623 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
tinyscheme_genesi... 4624 scheme *sc=(scheme*)malloc(sizeof(scheme));
tinyscheme_genesi... 4625 if(!scheme_init_custom_alloc(sc,malloc,free)) {
tinyscheme_genesi... 4626 free(sc);
tinyscheme_genesi... 4627 return 0;
tinyscheme_genesi... 4628 } else {
tinyscheme_genesi... 4629 return sc;
tinyscheme_genesi... 4630 }
tinyscheme_genesi... 4631 }
tinyscheme_genesi... 4632
tinyscheme_genesi... 4633
tinyscheme_genesi... 4634 int scheme_init(scheme *sc) {
tinyscheme_genesi... 4635 return scheme_init_custom_alloc(sc,malloc,free);
tinyscheme_genesi... 4636 }
tinyscheme_genesi... 4637
tinyscheme_genesi... 4638 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
tinyscheme_genesi... 4639 int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
tinyscheme_genesi... 4640 pointer x;
tinyscheme_genesi... 4641
asciilifeform_tin... 4642
asciilifeform_tin... 4643 memset( sc->load_stack, 0, sizeof(port) * MAXFIL );
asciilifeform_tin... 4644
tinyscheme_genesi... 4645 num_zero.is_fixnum=1;
tinyscheme_genesi... 4646 num_zero.value.ivalue=0;
tinyscheme_genesi... 4647 num_one.is_fixnum=1;
tinyscheme_genesi... 4648 num_one.value.ivalue=1;
tinyscheme_genesi... 4649
tinyscheme_genesi... 4650 #if USE_INTERFACE
tinyscheme_genesi... 4651 sc->vptr=&vtbl;
tinyscheme_genesi... 4652 #endif
tinyscheme_genesi... 4653 sc->gensym_cnt=0;
tinyscheme_genesi... 4654 sc->malloc=malloc;
tinyscheme_genesi... 4655 sc->free=free;
tinyscheme_genesi... 4656 sc->last_cell_seg = -1;
tinyscheme_genesi... 4657 sc->sink = &sc->_sink;
tinyscheme_genesi... 4658 sc->NIL = &sc->_NIL;
tinyscheme_genesi... 4659 sc->T = &sc->_HASHT;
tinyscheme_genesi... 4660 sc->F = &sc->_HASHF;
tinyscheme_genesi... 4661 sc->EOF_OBJ=&sc->_EOF_OBJ;
tinyscheme_genesi... 4662 sc->free_cell = &sc->_NIL;
tinyscheme_genesi... 4663 sc->fcells = 0;
tinyscheme_genesi... 4664 sc->no_memory=0;
tinyscheme_genesi... 4665 sc->inport=sc->NIL;
tinyscheme_genesi... 4666 sc->outport=sc->NIL;
tinyscheme_genesi... 4667 sc->save_inport=sc->NIL;
tinyscheme_genesi... 4668 sc->loadport=sc->NIL;
tinyscheme_genesi... 4669 sc->nesting=0;
tinyscheme_genesi... 4670 sc->interactive_repl=0;
tinyscheme_genesi... 4671
tinyscheme_genesi... 4672 if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
tinyscheme_genesi... 4673 sc->no_memory=1;
tinyscheme_genesi... 4674 return 0;
tinyscheme_genesi... 4675 }
tinyscheme_genesi... 4676 sc->gc_verbose = 0;
tinyscheme_genesi... 4677 dump_stack_initialize(sc);
tinyscheme_genesi... 4678 sc->code = sc->NIL;
tinyscheme_genesi... 4679 sc->tracing=0;
tinyscheme_genesi... 4680
tinyscheme_genesi... 4681
tinyscheme_genesi... 4682 typeflag(sc->NIL) = (T_ATOM | MARK);
tinyscheme_genesi... 4683 car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
tinyscheme_genesi... 4684
tinyscheme_genesi... 4685 typeflag(sc->T) = (T_ATOM | MARK);
tinyscheme_genesi... 4686 car(sc->T) = cdr(sc->T) = sc->T;
tinyscheme_genesi... 4687
tinyscheme_genesi... 4688 typeflag(sc->F) = (T_ATOM | MARK);
tinyscheme_genesi... 4689 car(sc->F) = cdr(sc->F) = sc->F;
tinyscheme_genesi... 4690
tinyscheme_genesi... 4691 typeflag(sc->sink) = (T_PAIR | MARK);
tinyscheme_genesi... 4692 car(sc->sink) = sc->NIL;
tinyscheme_genesi... 4693
tinyscheme_genesi... 4694 sc->c_nest = sc->NIL;
tinyscheme_genesi... 4695
tinyscheme_genesi... 4696 sc->oblist = oblist_initial_value(sc);
tinyscheme_genesi... 4697
tinyscheme_genesi... 4698 new_frame_in_env(sc, sc->NIL);
tinyscheme_genesi... 4699 sc->global_env = sc->envir;
tinyscheme_genesi... 4700
tinyscheme_genesi... 4701 x = mk_symbol(sc,"else");
tinyscheme_genesi... 4702 new_slot_in_env(sc, x, sc->T);
tinyscheme_genesi... 4703
tinyscheme_genesi... 4704 assign_syntax(sc, "lambda");
tinyscheme_genesi... 4705 assign_syntax(sc, "quote");
tinyscheme_genesi... 4706 assign_syntax(sc, "define");
tinyscheme_genesi... 4707 assign_syntax(sc, "if");
tinyscheme_genesi... 4708 assign_syntax(sc, "begin");
tinyscheme_genesi... 4709 assign_syntax(sc, "set!");
tinyscheme_genesi... 4710 assign_syntax(sc, "let");
tinyscheme_genesi... 4711 assign_syntax(sc, "let*");
tinyscheme_genesi... 4712 assign_syntax(sc, "letrec");
tinyscheme_genesi... 4713 assign_syntax(sc, "cond");
tinyscheme_genesi... 4714 assign_syntax(sc, "delay");
tinyscheme_genesi... 4715 assign_syntax(sc, "and");
tinyscheme_genesi... 4716 assign_syntax(sc, "or");
tinyscheme_genesi... 4717 assign_syntax(sc, "cons-stream");
tinyscheme_genesi... 4718 assign_syntax(sc, "macro");
tinyscheme_genesi... 4719 assign_syntax(sc, "case");
tinyscheme_genesi... 4720
tinyscheme_genesi... 4721 for(i=0; i<n; i++) {
tinyscheme_genesi... 4722 if(dispatch_table[i].name!=0) {
tinyscheme_genesi... 4723 assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
tinyscheme_genesi... 4724 }
tinyscheme_genesi... 4725 }
tinyscheme_genesi... 4726
tinyscheme_genesi... 4727
tinyscheme_genesi... 4728 sc->LAMBDA = mk_symbol(sc, "lambda");
tinyscheme_genesi... 4729 sc->QUOTE = mk_symbol(sc, "quote");
tinyscheme_genesi... 4730 sc->QQUOTE = mk_symbol(sc, "quasiquote");
tinyscheme_genesi... 4731 sc->UNQUOTE = mk_symbol(sc, "unquote");
tinyscheme_genesi... 4732 sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
tinyscheme_genesi... 4733 sc->FEED_TO = mk_symbol(sc, "=>");
tinyscheme_genesi... 4734 sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
tinyscheme_genesi... 4735 sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
tinyscheme_genesi... 4736 sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
tinyscheme_genesi... 4737 sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
tinyscheme_genesi... 4738
tinyscheme_genesi... 4739 return !sc->no_memory;
tinyscheme_genesi... 4740 }
tinyscheme_genesi... 4741
tinyscheme_genesi... 4742 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
tinyscheme_genesi... 4743 sc->inport=port_from_file(sc,fin,port_input);
tinyscheme_genesi... 4744 }
tinyscheme_genesi... 4745
tinyscheme_genesi... 4746 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
tinyscheme_genesi... 4747 sc->inport=port_from_string(sc,start,past_the_end,port_input);
tinyscheme_genesi... 4748 }
tinyscheme_genesi... 4749
tinyscheme_genesi... 4750 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
tinyscheme_genesi... 4751 sc->outport=port_from_file(sc,fout,port_output);
tinyscheme_genesi... 4752 }
tinyscheme_genesi... 4753
tinyscheme_genesi... 4754 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
tinyscheme_genesi... 4755 sc->outport=port_from_string(sc,start,past_the_end,port_output);
tinyscheme_genesi... 4756 }
tinyscheme_genesi... 4757
tinyscheme_genesi... 4758 void scheme_set_external_data(scheme *sc, void *p) {
tinyscheme_genesi... 4759 sc->ext_data=p;
tinyscheme_genesi... 4760 }
tinyscheme_genesi... 4761
tinyscheme_genesi... 4762 void scheme_deinit(scheme *sc) {
tinyscheme_genesi... 4763 int i;
tinyscheme_genesi... 4764
tinyscheme_genesi... 4765 #if SHOW_ERROR_LINE
tinyscheme_genesi... 4766 char *fname;
tinyscheme_genesi... 4767 #endif
tinyscheme_genesi... 4768
tinyscheme_genesi... 4769 sc->oblist=sc->NIL;
tinyscheme_genesi... 4770 sc->global_env=sc->NIL;
tinyscheme_genesi... 4771 dump_stack_free(sc);
tinyscheme_genesi... 4772 sc->envir=sc->NIL;
tinyscheme_genesi... 4773 sc->code=sc->NIL;
tinyscheme_genesi... 4774 sc->args=sc->NIL;
tinyscheme_genesi... 4775 sc->value=sc->NIL;
tinyscheme_genesi... 4776 if(is_port(sc->inport)) {
tinyscheme_genesi... 4777 typeflag(sc->inport) = T_ATOM;
tinyscheme_genesi... 4778 }
tinyscheme_genesi... 4779 sc->inport=sc->NIL;
tinyscheme_genesi... 4780 sc->outport=sc->NIL;
tinyscheme_genesi... 4781 if(is_port(sc->save_inport)) {
tinyscheme_genesi... 4782 typeflag(sc->save_inport) = T_ATOM;
tinyscheme_genesi... 4783 }
tinyscheme_genesi... 4784 sc->save_inport=sc->NIL;
tinyscheme_genesi... 4785 if(is_port(sc->loadport)) {
tinyscheme_genesi... 4786 typeflag(sc->loadport) = T_ATOM;
tinyscheme_genesi... 4787 }
tinyscheme_genesi... 4788 sc->loadport=sc->NIL;
tinyscheme_genesi... 4789 sc->gc_verbose=0;
tinyscheme_genesi... 4790 gc(sc,sc->NIL,sc->NIL);
tinyscheme_genesi... 4791
tinyscheme_genesi... 4792 for(i=0; i<=sc->last_cell_seg; i++) {
tinyscheme_genesi... 4793 sc->free(sc->alloc_seg[i]);
tinyscheme_genesi... 4794 }
tinyscheme_genesi... 4795
tinyscheme_genesi... 4796 #if SHOW_ERROR_LINE
tinyscheme_genesi... 4797 for(i=0; i<=sc->file_i; i++) {
tinyscheme_genesi... 4798 if (sc->load_stack[i].kind & port_file) {
tinyscheme_genesi... 4799 fname = sc->load_stack[i].rep.stdio.filename;
tinyscheme_genesi... 4800 if(fname)
tinyscheme_genesi... 4801 sc->free(fname);
tinyscheme_genesi... 4802 }
tinyscheme_genesi... 4803 }
tinyscheme_genesi... 4804 #endif
tinyscheme_genesi... 4805 }
tinyscheme_genesi... 4806
tinyscheme_genesi... 4807 void scheme_load_file(scheme *sc, FILE *fin)
tinyscheme_genesi... 4808 { scheme_load_named_file(sc,fin,0); }
tinyscheme_genesi... 4809
tinyscheme_genesi... 4810 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
asciilifeform_tin... 4811 int interactive_repl = sc->interactive_repl && !filename;
tinyscheme_genesi... 4812 dump_stack_reset(sc);
tinyscheme_genesi... 4813 sc->envir = sc->global_env;
tinyscheme_genesi... 4814 sc->file_i=0;
tinyscheme_genesi... 4815 sc->load_stack[0].kind=port_input|port_file;
tinyscheme_genesi... 4816 sc->load_stack[0].rep.stdio.file=fin;
asciilifeform_tin... 4817 sc->load_stack[0].rep.stdio.interactive=interactive_repl;
tinyscheme_genesi... 4818 sc->loadport=mk_port(sc,sc->load_stack);
tinyscheme_genesi... 4819 sc->retcode=0;
asciilifeform_tin... 4820 if(interactive_repl) {
asciilifeform_tin... 4821 sc->interactive_repl=interactive_repl;
tinyscheme_genesi... 4822 }
tinyscheme_genesi... 4823
tinyscheme_genesi... 4824 #if SHOW_ERROR_LINE
tinyscheme_genesi... 4825 sc->load_stack[0].rep.stdio.curr_line = 0;
tinyscheme_genesi... 4826 if(fin!=stdin && filename)
tinyscheme_genesi... 4827 sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
tinyscheme_genesi... 4828 #endif
tinyscheme_genesi... 4829
tinyscheme_genesi... 4830 sc->inport=sc->loadport;
tinyscheme_genesi... 4831 sc->args = mk_integer(sc,sc->file_i);
tinyscheme_genesi... 4832 Eval_Cycle(sc, OP_T0LVL);
tinyscheme_genesi... 4833 typeflag(sc->loadport)=T_ATOM;
tinyscheme_genesi... 4834 if(sc->retcode==0) {
tinyscheme_genesi... 4835 sc->retcode=sc->nesting!=0;
tinyscheme_genesi... 4836 }
tinyscheme_genesi... 4837 }
tinyscheme_genesi... 4838
tinyscheme_genesi... 4839 void scheme_load_string(scheme *sc, const char *cmd) {
tinyscheme_genesi... 4840 dump_stack_reset(sc);
tinyscheme_genesi... 4841 sc->envir = sc->global_env;
tinyscheme_genesi... 4842 sc->file_i=0;
tinyscheme_genesi... 4843 sc->load_stack[0].kind=port_input|port_string;
tinyscheme_genesi... 4844 sc->load_stack[0].rep.string.start=(char*)cmd;
tinyscheme_genesi... 4845 sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
tinyscheme_genesi... 4846 sc->load_stack[0].rep.string.curr=(char*)cmd;
tinyscheme_genesi... 4847 sc->loadport=mk_port(sc,sc->load_stack);
tinyscheme_genesi... 4848 sc->retcode=0;
tinyscheme_genesi... 4849 sc->interactive_repl=0;
tinyscheme_genesi... 4850 sc->inport=sc->loadport;
tinyscheme_genesi... 4851 sc->args = mk_integer(sc,sc->file_i);
tinyscheme_genesi... 4852 Eval_Cycle(sc, OP_T0LVL);
tinyscheme_genesi... 4853 typeflag(sc->loadport)=T_ATOM;
tinyscheme_genesi... 4854 if(sc->retcode==0) {
tinyscheme_genesi... 4855 sc->retcode=sc->nesting!=0;
tinyscheme_genesi... 4856 }
tinyscheme_genesi... 4857 }
tinyscheme_genesi... 4858
tinyscheme_genesi... 4859 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
tinyscheme_genesi... 4860 pointer x;
tinyscheme_genesi... 4861
tinyscheme_genesi... 4862 x=find_slot_in_env(sc,envir,symbol,0);
tinyscheme_genesi... 4863 if (x != sc->NIL) {
tinyscheme_genesi... 4864 set_slot_in_env(sc, x, value);
tinyscheme_genesi... 4865 } else {
tinyscheme_genesi... 4866 new_slot_spec_in_env(sc, envir, symbol, value);
tinyscheme_genesi... 4867 }
tinyscheme_genesi... 4868 }
tinyscheme_genesi... 4869
tinyscheme_genesi... 4870 #if !STANDALONE
tinyscheme_genesi... 4871 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
tinyscheme_genesi... 4872 {
tinyscheme_genesi... 4873 scheme_define(sc,
tinyscheme_genesi... 4874 sc->global_env,
tinyscheme_genesi... 4875 mk_symbol(sc,sr->name),
tinyscheme_genesi... 4876 mk_foreign_func(sc, sr->f));
tinyscheme_genesi... 4877 }
tinyscheme_genesi... 4878
tinyscheme_genesi... 4879 void scheme_register_foreign_func_list(scheme * sc,
tinyscheme_genesi... 4880 scheme_registerable * list,
tinyscheme_genesi... 4881 int count)
tinyscheme_genesi... 4882 {
tinyscheme_genesi... 4883 int i;
tinyscheme_genesi... 4884 for(i = 0; i < count; i++)
tinyscheme_genesi... 4885 {
tinyscheme_genesi... 4886 scheme_register_foreign_func(sc, list + i);
tinyscheme_genesi... 4887 }
tinyscheme_genesi... 4888 }
tinyscheme_genesi... 4889
tinyscheme_genesi... 4890 pointer scheme_apply0(scheme *sc, const char *procname)
tinyscheme_genesi... 4891 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
tinyscheme_genesi... 4892
tinyscheme_genesi... 4893 void save_from_C_call(scheme *sc)
tinyscheme_genesi... 4894 {
tinyscheme_genesi... 4895 pointer saved_data =
tinyscheme_genesi... 4896 cons(sc,
tinyscheme_genesi... 4897 car(sc->sink),
tinyscheme_genesi... 4898 cons(sc,
tinyscheme_genesi... 4899 sc->envir,
tinyscheme_genesi... 4900 sc->dump));
tinyscheme_genesi... 4901
tinyscheme_genesi... 4902 sc->c_nest = cons(sc, saved_data, sc->c_nest);
tinyscheme_genesi... 4903
tinyscheme_genesi... 4904 directly resume pre-C-call operations. */
tinyscheme_genesi... 4905 dump_stack_reset(sc);
tinyscheme_genesi... 4906 }
tinyscheme_genesi... 4907 void restore_from_C_call(scheme *sc)
tinyscheme_genesi... 4908 {
tinyscheme_genesi... 4909 car(sc->sink) = caar(sc->c_nest);
tinyscheme_genesi... 4910 sc->envir = cadar(sc->c_nest);
tinyscheme_genesi... 4911 sc->dump = cdr(cdar(sc->c_nest));
tinyscheme_genesi... 4912
tinyscheme_genesi... 4913 sc->c_nest = cdr(sc->c_nest);
tinyscheme_genesi... 4914 }
tinyscheme_genesi... 4915
tinyscheme_genesi... 4916
tinyscheme_genesi... 4917 pointer scheme_call(scheme *sc, pointer func, pointer args)
tinyscheme_genesi... 4918 {
tinyscheme_genesi... 4919 int old_repl = sc->interactive_repl;
tinyscheme_genesi... 4920 sc->interactive_repl = 0;
tinyscheme_genesi... 4921 save_from_C_call(sc);
tinyscheme_genesi... 4922 sc->envir = sc->global_env;
tinyscheme_genesi... 4923 sc->args = args;
tinyscheme_genesi... 4924 sc->code = func;
tinyscheme_genesi... 4925 sc->retcode = 0;
tinyscheme_genesi... 4926 Eval_Cycle(sc, OP_APPLY);
tinyscheme_genesi... 4927 sc->interactive_repl = old_repl;
tinyscheme_genesi... 4928 restore_from_C_call(sc);
tinyscheme_genesi... 4929 return sc->value;
tinyscheme_genesi... 4930 }
tinyscheme_genesi... 4931
tinyscheme_genesi... 4932 pointer scheme_eval(scheme *sc, pointer obj)
tinyscheme_genesi... 4933 {
tinyscheme_genesi... 4934 int old_repl = sc->interactive_repl;
tinyscheme_genesi... 4935 sc->interactive_repl = 0;
tinyscheme_genesi... 4936 save_from_C_call(sc);
tinyscheme_genesi... 4937 sc->args = sc->NIL;
tinyscheme_genesi... 4938 sc->code = obj;
tinyscheme_genesi... 4939 sc->retcode = 0;
tinyscheme_genesi... 4940 Eval_Cycle(sc, OP_EVAL);
tinyscheme_genesi... 4941 sc->interactive_repl = old_repl;
tinyscheme_genesi... 4942 restore_from_C_call(sc);
tinyscheme_genesi... 4943 return sc->value;
tinyscheme_genesi... 4944 }
tinyscheme_genesi... 4945
tinyscheme_genesi... 4946
tinyscheme_genesi... 4947 #endif
tinyscheme_genesi... 4948
tinyscheme_genesi... 4949
tinyscheme_genesi... 4950
tinyscheme_genesi... 4951 #if STANDALONE
tinyscheme_genesi... 4952
tinyscheme_genesi... 4953 #if defined(__APPLE__) && !defined (OSX)
tinyscheme_genesi... 4954 int main()
tinyscheme_genesi... 4955 {
tinyscheme_genesi... 4956 extern MacTS_main(int argc, char **argv);
tinyscheme_genesi... 4957 char** argv;
tinyscheme_genesi... 4958 int argc = ccommand(&argv);
tinyscheme_genesi... 4959 MacTS_main(argc,argv);
tinyscheme_genesi... 4960 return 0;
tinyscheme_genesi... 4961 }
tinyscheme_genesi... 4962 int MacTS_main(int argc, char **argv) {
tinyscheme_genesi... 4963 #else
tinyscheme_genesi... 4964 int main(int argc, char **argv) {
tinyscheme_genesi... 4965 #endif
tinyscheme_genesi... 4966 scheme sc;
tinyscheme_genesi... 4967 FILE *fin;
tinyscheme_genesi... 4968 char *file_name=InitFile;
tinyscheme_genesi... 4969 int retcode;
tinyscheme_genesi... 4970 int isfile=1;
tinyscheme_genesi... 4971
tinyscheme_genesi... 4972 if(argc==1) {
tinyscheme_genesi... 4973 printf(banner);
tinyscheme_genesi... 4974 }
tinyscheme_genesi... 4975 if(argc==2 && strcmp(argv[1],"-?")==0) {
tinyscheme_genesi... 4976 printf("Usage: tinyscheme -?\n");
tinyscheme_genesi... 4977 printf("or: tinyscheme [<file1> <file2> ...]\n");
tinyscheme_genesi... 4978 printf("followed by\n");
tinyscheme_genesi... 4979 printf(" -1 <file> [<arg1> <arg2> ...]\n");
tinyscheme_genesi... 4980 printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n");
tinyscheme_genesi... 4981 printf("assuming that the executable is named tinyscheme.\n");
tinyscheme_genesi... 4982 printf("Use - as filename for stdin.\n");
tinyscheme_genesi... 4983 return 1;
tinyscheme_genesi... 4984 }
tinyscheme_genesi... 4985 if(!scheme_init(&sc)) {
tinyscheme_genesi... 4986 fprintf(stderr,"Could not initialize!\n");
tinyscheme_genesi... 4987 return 2;
tinyscheme_genesi... 4988 }
tinyscheme_genesi... 4989 scheme_set_input_port_file(&sc, stdin);
tinyscheme_genesi... 4990 scheme_set_output_port_file(&sc, stdout);
tinyscheme_genesi... 4991 argv++;
tinyscheme_genesi... 4992 if(access(file_name,0)!=0) {
tinyscheme_genesi... 4993 char *p=getenv("TINYSCHEMEINIT");
tinyscheme_genesi... 4994 if(p!=0) {
tinyscheme_genesi... 4995 file_name=p;
tinyscheme_genesi... 4996 }
tinyscheme_genesi... 4997 }
tinyscheme_genesi... 4998 do {
tinyscheme_genesi... 4999 if(strcmp(file_name,"-")==0) {
tinyscheme_genesi... 5000 fin=stdin;
tinyscheme_genesi... 5001 } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
tinyscheme_genesi... 5002 pointer args=sc.NIL;
tinyscheme_genesi... 5003 isfile=file_name[1]=='1';
tinyscheme_genesi... 5004 file_name=*argv++;
tinyscheme_genesi... 5005 if(strcmp(file_name,"-")==0) {
tinyscheme_genesi... 5006 fin=stdin;
tinyscheme_genesi... 5007 } else if(isfile) {
tinyscheme_genesi... 5008 fin=fopen(file_name,"r");
tinyscheme_genesi... 5009 }
tinyscheme_genesi... 5010 for(;*argv;argv++) {
tinyscheme_genesi... 5011 pointer value=mk_string(&sc,*argv);
tinyscheme_genesi... 5012 args=cons(&sc,value,args);
tinyscheme_genesi... 5013 }
tinyscheme_genesi... 5014 args=reverse_in_place(&sc,sc.NIL,args);
tinyscheme_genesi... 5015 scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
tinyscheme_genesi... 5016
tinyscheme_genesi... 5017 } else {
tinyscheme_genesi... 5018 fin=fopen(file_name,"r");
tinyscheme_genesi... 5019 }
tinyscheme_genesi... 5020 if(isfile && fin==0) {
tinyscheme_genesi... 5021 fprintf(stderr,"Could not open file %s\n",file_name);
tinyscheme_genesi... 5022 } else {
tinyscheme_genesi... 5023 if(isfile) {
tinyscheme_genesi... 5024 scheme_load_named_file(&sc,fin,file_name);
tinyscheme_genesi... 5025 } else {
tinyscheme_genesi... 5026 scheme_load_string(&sc,file_name);
tinyscheme_genesi... 5027 }
tinyscheme_genesi... 5028 if(!isfile || fin!=stdin) {
tinyscheme_genesi... 5029 if(sc.retcode!=0) {
tinyscheme_genesi... 5030 fprintf(stderr,"Errors encountered reading %s\n",file_name);
tinyscheme_genesi... 5031 }
tinyscheme_genesi... 5032 if(isfile) {
tinyscheme_genesi... 5033 fclose(fin);
tinyscheme_genesi... 5034 }
tinyscheme_genesi... 5035 }
tinyscheme_genesi... 5036 }
tinyscheme_genesi... 5037 file_name=*argv++;
tinyscheme_genesi... 5038 } while(file_name!=0);
tinyscheme_genesi... 5039 if(argc==1) {
tinyscheme_genesi... 5040 scheme_load_named_file(&sc,stdin,0);
tinyscheme_genesi... 5041 }
tinyscheme_genesi... 5042 retcode=sc.retcode;
tinyscheme_genesi... 5043 scheme_deinit(&sc);
tinyscheme_genesi... 5044
tinyscheme_genesi... 5045 return retcode;
tinyscheme_genesi... 5046 }
tinyscheme_genesi... 5047
tinyscheme_genesi... 5048 #endif
tinyscheme_genesi... 5049
tinyscheme_genesi... 5050
tinyscheme_genesi... 5051 Local variables:
tinyscheme_genesi... 5052 c-file-style: "k&r"
tinyscheme_genesi... 5053 End:
tinyscheme_genesi... 5054 */