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