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