ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/microscheme/scheme.c
(Generate patch)

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.9 by root, Wed Nov 25 22:39:19 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1
22
23#if 1
21#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22#include "malloc.c" 25#include "malloc.c"
26#endif
23 27
24#define SCHEME_SOURCE 28#define SCHEME_SOURCE
25#include "scheme-private.h" 29#include "scheme-private.h"
26#ifndef WIN32 30#ifndef WIN32
27# include <unistd.h> 31# include <unistd.h>
28#endif 32#endif
29#if USE_MATH 33#if USE_MATH
30# include <math.h> 34# include <math.h>
31#endif 35#endif
32 36
37#include "ecb.h"
38
33#include <sys/types.h> 39#include <sys/types.h>
34#include <sys/stat.h> 40#include <sys/stat.h>
35#include <fcntl.h> 41#include <fcntl.h>
36 42
43#if !USE_ERROR_CHECKING
44# define NDEBUG
45#endif
46
47#include <assert.h>
48#include <stdlib.h>
37#include <string.h> 49#include <string.h>
38#include <stdlib.h>
39 50
40#include <limits.h> 51#include <limits.h>
41#include <inttypes.h> 52#include <inttypes.h>
42#include <float.h> 53#include <float.h>
43//#include <ctype.h> 54//#include <ctype.h>
55
56#if '1' != '0' + 1 \
57 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
58 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
59 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
60 || 'f' != 'a' + 5
61# error "execution character set digits not consecutive"
62#endif
44 63
45enum { 64enum {
46 TOK_EOF, 65 TOK_EOF,
47 TOK_LPAREN, 66 TOK_LPAREN,
48 TOK_RPAREN, 67 TOK_RPAREN,
49 TOK_DOT, 68 TOK_DOT,
50 TOK_ATOM, 69 TOK_ATOM,
70 TOK_DOTATOM, /* atom name starting with '.' */
71 TOK_STRATOM, /* atom name enclosed in | */
51 TOK_QUOTE, 72 TOK_QUOTE,
52 TOK_DQUOTE, 73 TOK_DQUOTE,
53 TOK_BQUOTE, 74 TOK_BQUOTE,
54 TOK_COMMA, 75 TOK_COMMA,
55 TOK_ATMARK, 76 TOK_ATMARK,
… …
57 TOK_SHARP_CONST, 78 TOK_SHARP_CONST,
58 TOK_VEC 79 TOK_VEC
59}; 80};
60 81
61#define BACKQUOTE '`' 82#define BACKQUOTE '`'
62#define DELIMITERS "()\";\f\t\v\n\r " 83#define WHITESPACE " \t\r\n\v\f"
84#define DELIMITERS "()\";" WHITESPACE
63 85
64#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 86#define NIL POINTER (&SCHEME_V->xNIL)
65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 87#define S_T POINTER (&SCHEME_V->xT)
66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 88#define S_F POINTER (&SCHEME_V->xF)
67#define S_SINK (&SCHEME_V->xsink) 89#define S_SINK POINTER (&SCHEME_V->xsink)
68#define S_EOF (&SCHEME_V->xEOF_OBJ) 90#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
69 91
70#if !USE_MULTIPLICITY 92#if !USE_MULTIPLICITY
71static scheme sc; 93static scheme sc;
72#endif 94#endif
73 95
74static void 96ecb_cold static void
75xbase (char *s, long n, int base) 97xbase (char *s, long n, int base)
76{ 98{
77 if (n < 0) 99 if (n < 0)
78 { 100 {
79 *s++ = '-'; 101 *s++ = '-';
… …
81 } 103 }
82 104
83 char *p = s; 105 char *p = s;
84 106
85 do { 107 do {
86 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
87 n /= base; 109 n /= base;
88 } while (n); 110 } while (n);
89 111
90 *p-- = 0; 112 *p-- = 0;
91 113
… …
94 char x = *s; *s = *p; *p = x; 116 char x = *s; *s = *p; *p = x;
95 --p; ++s; 117 --p; ++s;
96 } 118 }
97} 119}
98 120
99static void 121ecb_cold static void
100xnum (char *s, long n) 122xnum (char *s, long n)
101{ 123{
102 xbase (s, n, 10); 124 xbase (s, n, 10);
103} 125}
104 126
105static void 127ecb_cold static void
106xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
107{
108 write (1, s, strlen (s));
109}
110
111static void
112xwrnum (long n)
113{ 129{
114 char buf[64]; 130 char buf[64];
115 131
116 xnum (buf, n); 132 xnum (buf, n);
117 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
118} 134}
119 135
120static char 136ecb_cold static char
121xtoupper (char c) 137xtoupper (char c)
122{ 138{
123 if (c >= 'a' && c <= 'z') 139 if (c >= 'a' && c <= 'z')
124 c -= 'a' - 'A'; 140 c -= 'a' - 'A';
125 141
126 return c; 142 return c;
127} 143}
128 144
129static char 145ecb_cold static char
130xtolower (char c) 146xtolower (char c)
131{ 147{
132 if (c >= 'A' && c <= 'Z') 148 if (c >= 'A' && c <= 'Z')
133 c += 'a' - 'A'; 149 c += 'a' - 'A';
134 150
135 return c; 151 return c;
136} 152}
137 153
138static int 154ecb_cold static int
139xisdigit (char c) 155xisdigit (char c)
140{ 156{
141 return c >= '0' && c <= '9'; 157 return c >= '0' && c <= '9';
142} 158}
143 159
144#define toupper(c) xtoupper (c) 160#define toupper(c) xtoupper (c)
145#define tolower(c) xtolower (c) 161#define tolower(c) xtolower (c)
146#define isdigit(c) xisdigit (c) 162#define isdigit(c) xisdigit (c)
147 163
148#if USE_STRLWR 164#if USE_IGNORECASE
149static const char * 165ecb_cold static const char *
150strlwr (char *s) 166xstrlwr (char *s)
151{ 167{
152 const char *p = s; 168 const char *p = s;
153 169
154 while (*s) 170 while (*s)
155 { 171 {
… …
157 s++; 173 s++;
158 } 174 }
159 175
160 return p; 176 return p;
161} 177}
162#endif
163 178
179#define stricmp(a,b) strcasecmp (a, b)
180#define strlwr(s) xstrlwr (s)
181
182#else
164#define stricmp(a,b) strcmp (a, b) 183# define stricmp(a,b) strcmp (a, b)
165#define strlwr(s) (s) 184# define strlwr(s) (s)
185#endif
166 186
167#ifndef prompt 187#ifndef prompt
168# define prompt "ts> " 188# define prompt "ts> "
169#endif 189#endif
170 190
171#ifndef InitFile 191#ifndef InitFile
172# define InitFile "init.scm" 192# define InitFile "init.scm"
173#endif 193#endif
174 194
175#ifndef FIRST_CELLSEGS
176# define FIRST_CELLSEGS 3
177#endif
178
179enum scheme_types 195enum scheme_types
180{ 196{
197 T_INTEGER,
198 T_CHARACTER,
181 T_FREE, 199 T_REAL,
182 T_STRING, 200 T_STRING,
183 T_NUMBER,
184 T_SYMBOL, 201 T_SYMBOL,
185 T_PROC, 202 T_PROC,
186 T_PAIR, 203 T_PAIR, /* also used for free cells */
187 T_CLOSURE, 204 T_CLOSURE,
205 T_MACRO,
188 T_CONTINUATION, 206 T_CONTINUATION,
189 T_FOREIGN, 207 T_FOREIGN,
190 T_CHARACTER,
191 T_PORT, 208 T_PORT,
192 T_VECTOR, 209 T_VECTOR,
193 T_MACRO,
194 T_PROMISE, 210 T_PROMISE,
195 T_ENVIRONMENT, 211 T_ENVIRONMENT,
196 /* one more... */ 212 /* one more... */
197 T_NUM_SYSTEM_TYPES 213 T_NUM_SYSTEM_TYPES
198}; 214};
… …
201#define T_SYNTAX 0x0010 217#define T_SYNTAX 0x0010
202#define T_IMMUTABLE 0x0020 218#define T_IMMUTABLE 0x0020
203#define T_ATOM 0x0040 /* only for gc */ 219#define T_ATOM 0x0040 /* only for gc */
204#define T_MARK 0x0080 /* only for gc */ 220#define T_MARK 0x0080 /* only for gc */
205 221
206static num num_add (num a, num b); 222/* num, for generic arithmetic */
207static num num_mul (num a, num b); 223struct num
208static num num_div (num a, num b); 224{
225 IVALUE ivalue;
226#if USE_REAL
227 RVALUE rvalue;
228 char is_fixnum;
229#endif
230};
231
232#if USE_REAL
233# define num_is_fixnum(n) (n).is_fixnum
234# define num_set_fixnum(n,f) (n).is_fixnum = (f)
235# define num_ivalue(n) (n).ivalue
236# define num_rvalue(n) (n).rvalue
237# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
238# define num_set_rvalue(n,r) (n).rvalue = (r)
239#else
240# define num_is_fixnum(n) 1
241# define num_set_fixnum(n,f) 0
242# define num_ivalue(n) (n).ivalue
243# define num_rvalue(n) (n).ivalue
244# define num_set_ivalue(n,i) (n).ivalue = (i)
245# define num_set_rvalue(n,r) (n).ivalue = (r)
246#endif
247
248enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
249
250static num num_op (enum num_op op, num a, num b);
209static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
210static num num_sub (num a, num b);
211static num num_rem (num a, num b); 252static num num_rem (num a, num b);
212static num num_mod (num a, num b); 253static num num_mod (num a, num b);
213static int num_eq (num a, num b);
214static int num_gt (num a, num b);
215static int num_ge (num a, num b);
216static int num_lt (num a, num b);
217static int num_le (num a, num b);
218 254
219#if USE_MATH
220static double round_per_R5RS (double x);
221#endif
222static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
223
224static INLINE int
225num_is_integer (pointer p)
226{
227 return num_is_fixnum (p->object.number);
228}
229 256
230static num num_zero; 257static num num_zero;
231static num num_one; 258static num num_one;
232 259
260/* convert "pointer" to cell* / cell* to pointer */
261#define CELL(p) ((struct cell *)(p) + 0)
262#define POINTER(c) ((void *)((c) - 0))
263
233/* macros for cell operations */ 264/* macros for cell operations */
234#define typeflag(p) ((p)->flag + 0) 265#define typeflag(p) (CELL(p)->flag + 0)
235#define set_typeflag(p,v) ((p)->flag = (v)) 266#define set_typeflag(p,v) (CELL(p)->flag = (v))
236#define type(p) (typeflag (p) & T_MASKTYPE) 267#define type(p) (typeflag (p) & T_MASKTYPE)
237 268
238INTERFACE INLINE int 269INTERFACE int
239is_string (pointer p) 270is_string (pointer p)
240{ 271{
241 return type (p) == T_STRING; 272 return type (p) == T_STRING;
242} 273}
243 274
244#define strvalue(p) ((p)->object.string.svalue) 275#define strvalue(p) (CELL(p)->object.string.svalue)
245#define strlength(p) ((p)->object.string.length) 276#define strlength(p) (CELL(p)->object.string.length)
246 277
247INTERFACE int is_list (SCHEME_P_ pointer p);
248INTERFACE INLINE int 278INTERFACE int
249is_vector (pointer p) 279is_vector (pointer p)
250{ 280{
251 return type (p) == T_VECTOR; 281 return type (p) == T_VECTOR;
252} 282}
253 283
254#define vecvalue(p) ((p)->object.vector.vvalue) 284#define vecvalue(p) (CELL(p)->object.vector.vvalue)
255#define veclength(p) ((p)->object.vector.length) 285#define veclength(p) (CELL(p)->object.vector.length)
256INTERFACE void fill_vector (pointer vec, pointer obj); 286INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
257INTERFACE uint32_t vector_length (pointer vec);
258INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 287INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
259INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 288INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
260 289
261INTERFACE uint32_t 290INTERFACE int
262vector_length (pointer vec) 291is_integer (pointer p)
263{ 292{
264 return vec->object.vector.length; 293 return type (p) == T_INTEGER;
265} 294}
266 295
296/* not the same as in scheme, where integers are (correctly :) reals */
267INTERFACE INLINE int 297INTERFACE int
298is_real (pointer p)
299{
300 return type (p) == T_REAL;
301}
302
303INTERFACE int
268is_number (pointer p) 304is_number (pointer p)
269{ 305{
270 return type (p) == T_NUMBER; 306 return is_integer (p) || is_real (p);
271} 307}
272 308
273INTERFACE INLINE int 309INTERFACE int
274is_integer (pointer p)
275{
276 if (!is_number (p))
277 return 0;
278
279 if (num_is_integer (p) || ivalue (p) == rvalue (p))
280 return 1;
281
282 return 0;
283}
284
285INTERFACE INLINE int
286is_real (pointer p)
287{
288 return is_number (p) && !num_is_fixnum (p->object.number);
289}
290
291INTERFACE INLINE int
292is_character (pointer p) 310is_character (pointer p)
293{ 311{
294 return type (p) == T_CHARACTER; 312 return type (p) == T_CHARACTER;
295} 313}
296 314
297INTERFACE INLINE char * 315INTERFACE char *
298string_value (pointer p) 316string_value (pointer p)
299{ 317{
300 return strvalue (p); 318 return strvalue (p);
301} 319}
302 320
303INLINE num
304nvalue (pointer p)
305{
306 return (p)->object.number;
307}
308
309static IVALUE
310num_get_ivalue (const num n)
311{
312 return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
313}
314
315static RVALUE
316num_get_rvalue (const num n)
317{
318 return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
319}
320
321INTERFACE IVALUE
322ivalue (pointer p)
323{
324 return num_get_ivalue (p->object.number);
325}
326
327INTERFACE RVALUE
328rvalue (pointer p)
329{
330 return num_get_rvalue (p->object.number);
331}
332
333#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 321#define ivalue_unchecked(p) CELL(p)->object.ivalue
322#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
323
334#if USE_REAL 324#if USE_REAL
335# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 325#define rvalue_unchecked(p) CELL(p)->object.rvalue
336# define set_num_integer(p) (p)->object.number.is_fixnum=1; 326#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
337# define set_num_real(p) (p)->object.number.is_fixnum=0;
338#else 327#else
339# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 328#define rvalue_unchecked(p) CELL(p)->object.ivalue
340# define set_num_integer(p) 0 329#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
341# define set_num_real(p) 0
342#endif 330#endif
331
343INTERFACE long 332INTERFACE long
344charvalue (pointer p) 333charvalue (pointer p)
345{ 334{
346 return ivalue_unchecked (p); 335 return ivalue_unchecked (p);
347} 336}
348 337
338#define port(p) CELL(p)->object.port
339#define set_port(p,v) port(p) = (v)
349INTERFACE INLINE int 340INTERFACE int
350is_port (pointer p) 341is_port (pointer p)
351{ 342{
352 return type (p) == T_PORT; 343 return type (p) == T_PORT;
353} 344}
354 345
355INTERFACE INLINE int 346INTERFACE int
356is_inport (pointer p) 347is_inport (pointer p)
357{ 348{
358 return is_port (p) && p->object.port->kind & port_input; 349 return is_port (p) && port (p)->kind & port_input;
359} 350}
360 351
361INTERFACE INLINE int 352INTERFACE int
362is_outport (pointer p) 353is_outport (pointer p)
363{ 354{
364 return is_port (p) && p->object.port->kind & port_output; 355 return is_port (p) && port (p)->kind & port_output;
365} 356}
366 357
367INTERFACE INLINE int 358INTERFACE int
368is_pair (pointer p) 359is_pair (pointer p)
369{ 360{
370 return type (p) == T_PAIR; 361 return type (p) == T_PAIR;
371} 362}
372 363
373#define car(p) ((p)->object.cons.car + 0) 364#define car(p) (POINTER (CELL(p)->object.cons.car))
374#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 365#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
375 366
376#define caar(p) car (car (p)) 367static pointer caar (pointer p) { return car (car (p)); }
377#define cadr(p) car (cdr (p)) 368static pointer cadr (pointer p) { return car (cdr (p)); }
378#define cdar(p) cdr (car (p)) 369static pointer cdar (pointer p) { return cdr (car (p)); }
379#define cddr(p) cdr (cdr (p)) 370static pointer cddr (pointer p) { return cdr (cdr (p)); }
380 371
381#define cadar(p) car (cdr (car (p))) 372static pointer cadar (pointer p) { return car (cdr (car (p))); }
382#define caddr(p) car (cdr (cdr (p))) 373static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
383#define cdaar(p) cdr (car (car (p))) 374static pointer cdaar (pointer p) { return cdr (car (car (p))); }
384 375
385INTERFACE void 376INTERFACE void
386set_car (pointer p, pointer q) 377set_car (pointer p, pointer q)
387{ 378{
388 p->object.cons.car = q; 379 CELL(p)->object.cons.car = CELL (q);
389} 380}
390 381
391INTERFACE void 382INTERFACE void
392set_cdr (pointer p, pointer q) 383set_cdr (pointer p, pointer q)
393{ 384{
394 p->object.cons.cdr = q; 385 CELL(p)->object.cons.cdr = CELL (q);
395} 386}
396 387
397INTERFACE pointer 388INTERFACE pointer
398pair_car (pointer p) 389pair_car (pointer p)
399{ 390{
… …
404pair_cdr (pointer p) 395pair_cdr (pointer p)
405{ 396{
406 return cdr (p); 397 return cdr (p);
407} 398}
408 399
409INTERFACE INLINE int 400INTERFACE int
410is_symbol (pointer p) 401is_symbol (pointer p)
411{ 402{
412 return type (p) == T_SYMBOL; 403 return type (p) == T_SYMBOL;
413} 404}
414 405
415INTERFACE INLINE char * 406INTERFACE char *
416symname (pointer p) 407symname (pointer p)
417{ 408{
418 return strvalue (car (p)); 409 return strvalue (p);
419} 410}
420 411
421#if USE_PLIST 412#if USE_PLIST
413#error plists are broken because symbols are no longer pairs
414#define symprop(p) cdr(p)
422SCHEME_EXPORT INLINE int 415SCHEME_EXPORT int
423hasprop (pointer p) 416hasprop (pointer p)
424{ 417{
425 return typeflag (p) & T_SYMBOL; 418 return typeflag (p) & T_SYMBOL;
426} 419}
427
428# define symprop(p) cdr(p)
429#endif 420#endif
430 421
431INTERFACE INLINE int 422INTERFACE int
432is_syntax (pointer p) 423is_syntax (pointer p)
433{ 424{
434 return typeflag (p) & T_SYNTAX; 425 return typeflag (p) & T_SYNTAX;
435} 426}
436 427
437INTERFACE INLINE int 428INTERFACE int
438is_proc (pointer p) 429is_proc (pointer p)
439{ 430{
440 return type (p) == T_PROC; 431 return type (p) == T_PROC;
441} 432}
442 433
443INTERFACE INLINE int 434INTERFACE int
444is_foreign (pointer p) 435is_foreign (pointer p)
445{ 436{
446 return type (p) == T_FOREIGN; 437 return type (p) == T_FOREIGN;
447} 438}
448 439
449INTERFACE INLINE char * 440INTERFACE char *
450syntaxname (pointer p) 441syntaxname (pointer p)
451{ 442{
452 return strvalue (car (p)); 443 return strvalue (p);
453} 444}
454 445
455#define procnum(p) ivalue (p) 446#define procnum(p) ivalue_unchecked (p)
456static const char *procname (pointer x); 447static const char *procname (pointer x);
457 448
458INTERFACE INLINE int 449INTERFACE int
459is_closure (pointer p) 450is_closure (pointer p)
460{ 451{
461 return type (p) == T_CLOSURE; 452 return type (p) == T_CLOSURE;
462} 453}
463 454
464INTERFACE INLINE int 455INTERFACE int
465is_macro (pointer p) 456is_macro (pointer p)
466{ 457{
467 return type (p) == T_MACRO; 458 return type (p) == T_MACRO;
468} 459}
469 460
470INTERFACE INLINE pointer 461INTERFACE pointer
471closure_code (pointer p) 462closure_code (pointer p)
472{ 463{
473 return car (p); 464 return car (p);
474} 465}
475 466
476INTERFACE INLINE pointer 467INTERFACE pointer
477closure_env (pointer p) 468closure_env (pointer p)
478{ 469{
479 return cdr (p); 470 return cdr (p);
480} 471}
481 472
482INTERFACE INLINE int 473INTERFACE int
483is_continuation (pointer p) 474is_continuation (pointer p)
484{ 475{
485 return type (p) == T_CONTINUATION; 476 return type (p) == T_CONTINUATION;
486} 477}
487 478
488#define cont_dump(p) cdr (p) 479#define cont_dump(p) cdr (p)
489#define set_cont_dump(p,v) set_cdr ((p), (v)) 480#define set_cont_dump(p,v) set_cdr ((p), (v))
490 481
491/* To do: promise should be forced ONCE only */ 482/* To do: promise should be forced ONCE only */
492INTERFACE INLINE int 483INTERFACE int
493is_promise (pointer p) 484is_promise (pointer p)
494{ 485{
495 return type (p) == T_PROMISE; 486 return type (p) == T_PROMISE;
496} 487}
497 488
498INTERFACE INLINE int 489INTERFACE int
499is_environment (pointer p) 490is_environment (pointer p)
500{ 491{
501 return type (p) == T_ENVIRONMENT; 492 return type (p) == T_ENVIRONMENT;
502} 493}
503 494
… …
509 500
510#define is_mark(p) (typeflag (p) & T_MARK) 501#define is_mark(p) (typeflag (p) & T_MARK)
511#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 502#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
512#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 503#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
513 504
514INTERFACE INLINE int 505INTERFACE int
515is_immutable (pointer p) 506is_immutable (pointer p)
516{ 507{
517 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 508 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
518} 509}
519 510
520INTERFACE INLINE void 511INTERFACE void
521setimmutable (pointer p) 512setimmutable (pointer p)
522{ 513{
523#if USE_ERROR_CHECKING 514#if USE_ERROR_CHECKING
524 set_typeflag (p, typeflag (p) | T_IMMUTABLE); 515 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
525#endif 516#endif
526} 517}
527 518
519/* Result is:
520 proper list: length
521 circular list: -1
522 not even a pair: -2
523 dotted list: -2 minus length before dot
524*/
525ecb_hot INTERFACE int
526list_length (SCHEME_P_ pointer a)
527{
528 int i = 0;
529 pointer slow, fast;
530
531 slow = fast = a;
532
533 while (1)
534 {
535 if (fast == NIL)
536 return i;
537
538 if (!is_pair (fast))
539 return -2 - i;
540
541 fast = cdr (fast);
542 ++i;
543
544 if (fast == NIL)
545 return i;
546
547 if (!is_pair (fast))
548 return -2 - i;
549
550 ++i;
551 fast = cdr (fast);
552
553 /* Safe because we would have already returned if `fast'
554 encountered a non-pair. */
555 slow = cdr (slow);
556
557 if (fast == slow)
558 {
559 /* the fast pointer has looped back around and caught up
560 with the slow pointer, hence the structure is circular,
561 not of finite length, and therefore not a list */
562 return -1;
563 }
564 }
565}
566
567INTERFACE int
568is_list (SCHEME_P_ pointer a)
569{
570 return list_length (SCHEME_A_ a) >= 0;
571}
572
528#if USE_CHAR_CLASSIFIERS 573#if USE_CHAR_CLASSIFIERS
529static INLINE int 574ecb_inline int
530Cisalpha (int c) 575Cisalpha (int c)
531{ 576{
532 return isascii (c) && isalpha (c); 577 return isascii (c) && isalpha (c);
533} 578}
534 579
535static INLINE int 580ecb_inline int
536Cisdigit (int c) 581Cisdigit (int c)
537{ 582{
538 return isascii (c) && isdigit (c); 583 return isascii (c) && isdigit (c);
539} 584}
540 585
541static INLINE int 586ecb_inline int
542Cisspace (int c) 587Cisspace (int c)
543{ 588{
544 return isascii (c) && isspace (c); 589 return isascii (c) && isspace (c);
545} 590}
546 591
547static INLINE int 592ecb_inline int
548Cisupper (int c) 593Cisupper (int c)
549{ 594{
550 return isascii (c) && isupper (c); 595 return isascii (c) && isupper (c);
551} 596}
552 597
553static INLINE int 598ecb_inline int
554Cislower (int c) 599Cislower (int c)
555{ 600{
556 return isascii (c) && islower (c); 601 return isascii (c) && islower (c);
557} 602}
558#endif 603#endif
… …
591 "gs", 636 "gs",
592 "rs", 637 "rs",
593 "us" 638 "us"
594}; 639};
595 640
596static int 641ecb_cold static int
597is_ascii_name (const char *name, int *pc) 642is_ascii_name (const char *name, int *pc)
598{ 643{
599 int i; 644 int i;
600 645
601 for (i = 0; i < 32; i++) 646 for (i = 0; i < 32; i++)
… …
619#endif 664#endif
620 665
621static int file_push (SCHEME_P_ const char *fname); 666static int file_push (SCHEME_P_ const char *fname);
622static void file_pop (SCHEME_P); 667static void file_pop (SCHEME_P);
623static int file_interactive (SCHEME_P); 668static int file_interactive (SCHEME_P);
624static INLINE int is_one_of (char *s, int c); 669ecb_inline int is_one_of (const char *s, int c);
625static int alloc_cellseg (SCHEME_P_ int n); 670static int alloc_cellseg (SCHEME_P);
626static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
627static void finalize_cell (SCHEME_P_ pointer a); 672static void finalize_cell (SCHEME_P_ pointer a);
628static int count_consecutive_cells (pointer x, int needed); 673static int count_consecutive_cells (pointer x, int needed);
629static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 674static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
630static pointer mk_number (SCHEME_P_ const num n); 675static pointer mk_number (SCHEME_P_ const num n);
631static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 676static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
… …
646static void mark (pointer a); 691static void mark (pointer a);
647static void gc (SCHEME_P_ pointer a, pointer b); 692static void gc (SCHEME_P_ pointer a, pointer b);
648static int basic_inchar (port *pt); 693static int basic_inchar (port *pt);
649static int inchar (SCHEME_P); 694static int inchar (SCHEME_P);
650static void backchar (SCHEME_P_ int c); 695static void backchar (SCHEME_P_ int c);
651static char *readstr_upto (SCHEME_P_ char *delim); 696static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
652static pointer readstrexp (SCHEME_P); 697static pointer readstrexp (SCHEME_P_ char delim);
653static INLINE int skipspace (SCHEME_P); 698ecb_inline int skipspace (SCHEME_P);
654static int token (SCHEME_P); 699static int token (SCHEME_P);
655static void printslashstring (SCHEME_P_ char *s, int len); 700static void printslashstring (SCHEME_P_ char *s, int len);
656static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 701static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
657static void printatom (SCHEME_P_ pointer l, int f); 702static void printatom (SCHEME_P_ pointer l, int f);
658static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 703static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
662static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); 707static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
663static pointer revappend (SCHEME_P_ pointer a, pointer b); 708static pointer revappend (SCHEME_P_ pointer a, pointer b);
664static pointer ss_get_cont (SCHEME_P); 709static pointer ss_get_cont (SCHEME_P);
665static void ss_set_cont (SCHEME_P_ pointer cont); 710static void ss_set_cont (SCHEME_P_ pointer cont);
666static void dump_stack_mark (SCHEME_P); 711static void dump_stack_mark (SCHEME_P);
667static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 712static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
713static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
668static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); 714static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
669static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 715static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
670static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 716static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
671static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 717static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
672static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 718static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
673static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 719static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
674static void assign_syntax (SCHEME_P_ const char *name); 720static void assign_syntax (SCHEME_P_ const char *name);
675static int syntaxnum (pointer p); 721static int syntaxnum (pointer p);
676static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 722static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
677 723
724static IVALUE
725ivalue (pointer x)
726{
727 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
728}
729
730static RVALUE
731rvalue (pointer x)
732{
733 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
734}
735
736INTERFACE num
737nvalue (pointer x)
738{
739 num n;
740
741 num_set_fixnum (n, is_integer (x));
742
743 if (num_is_fixnum (n))
744 num_set_ivalue (n, ivalue_unchecked (x));
745 else
746 num_set_rvalue (n, rvalue_unchecked (x));
747
748 return n;
749}
750
678static num 751static num
679num_add (num a, num b) 752num_op (enum num_op op, num a, num b)
680{ 753{
681 num ret; 754 num ret;
682 755
683 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 756 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
684 757
685 if (num_is_fixnum (ret)) 758 if (num_is_fixnum (ret))
686 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); 759 {
760 switch (op)
761 {
762 case NUM_ADD: a.ivalue += b.ivalue; break;
763 case NUM_SUB: a.ivalue -= b.ivalue; break;
764 case NUM_MUL: a.ivalue *= b.ivalue; break;
765 case NUM_INTDIV: a.ivalue /= b.ivalue; break;
766 }
767
768 num_set_ivalue (ret, a.ivalue);
769 }
770#if USE_REAL
687 else 771 else
688 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); 772 {
773 switch (op)
774 {
775 case NUM_ADD: a.rvalue += b.rvalue; break;
776 case NUM_SUB: a.rvalue -= b.rvalue; break;
777 case NUM_MUL: a.rvalue *= b.rvalue; break;
778 case NUM_INTDIV: a.rvalue /= b.rvalue; break;
779 }
689 780
690 return ret; 781 num_set_rvalue (ret, a.rvalue);
691} 782 }
692 783#endif
693static num
694num_mul (num a, num b)
695{
696 num ret;
697
698 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
699
700 if (num_is_fixnum (ret))
701 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
702 else
703 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
704 784
705 return ret; 785 return ret;
706} 786}
707 787
708static num 788static num
709num_div (num a, num b) 789num_div (num a, num b)
710{ 790{
711 num ret; 791 num ret;
712 792
713 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); 793 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
714 794
715 if (num_is_fixnum (ret)) 795 if (num_is_fixnum (ret))
716 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); 796 num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
717 else 797 else
718 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); 798 num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
719
720 return ret;
721}
722
723static num
724num_intdiv (num a, num b)
725{
726 num ret;
727
728 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
729
730 if (num_is_fixnum (ret))
731 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
732 else
733 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
734
735 return ret;
736}
737
738static num
739num_sub (num a, num b)
740{
741 num ret;
742
743 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
744
745 if (num_is_fixnum (ret))
746 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
747 else
748 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
749 799
750 return ret; 800 return ret;
751} 801}
752 802
753static num 803static num
… …
755{ 805{
756 num ret; 806 num ret;
757 long e1, e2, res; 807 long e1, e2, res;
758 808
759 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 809 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
760 e1 = num_get_ivalue (a); 810 e1 = num_ivalue (a);
761 e2 = num_get_ivalue (b); 811 e2 = num_ivalue (b);
762 res = e1 % e2; 812 res = e1 % e2;
763 813
764 /* remainder should have same sign as second operand */ 814 /* remainder should have same sign as second operand */
765 if (res > 0) 815 if (res > 0)
766 { 816 {
… …
782{ 832{
783 num ret; 833 num ret;
784 long e1, e2, res; 834 long e1, e2, res;
785 835
786 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 836 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
787 e1 = num_get_ivalue (a); 837 e1 = num_ivalue (a);
788 e2 = num_get_ivalue (b); 838 e2 = num_ivalue (b);
789 res = e1 % e2; 839 res = e1 % e2;
790 840
791 /* modulo should have same sign as second operand */ 841 /* modulo should have same sign as second operand */
792 if (res * e2 < 0) 842 if (res * e2 < 0)
793 res += e2; 843 res += e2;
794 844
795 num_set_ivalue (ret, res); 845 num_set_ivalue (ret, res);
796 return ret; 846 return ret;
797} 847}
798 848
849/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
799static int 850static int
800num_eq (num a, num b) 851num_cmp (num a, num b)
801{ 852{
853 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
802 int ret; 854 int ret;
803 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
804 855
805 if (is_fixnum) 856 if (is_fixnum)
806 ret = num_get_ivalue (a) == num_get_ivalue (b); 857 {
858 IVALUE av = num_ivalue (a);
859 IVALUE bv = num_ivalue (b);
860
861 ret = av == bv ? 0 : av < bv ? -1 : +1;
862 }
807 else 863 else
808 ret = num_get_rvalue (a) == num_get_rvalue (b); 864 {
865 RVALUE av = num_rvalue (a);
866 RVALUE bv = num_rvalue (b);
867
868 ret = av == bv ? 0 : av < bv ? -1 : +1;
869 }
809 870
810 return ret; 871 return ret;
811} 872}
812
813
814static int
815num_gt (num a, num b)
816{
817 int ret;
818 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
819
820 if (is_fixnum)
821 ret = num_get_ivalue (a) > num_get_ivalue (b);
822 else
823 ret = num_get_rvalue (a) > num_get_rvalue (b);
824
825 return ret;
826}
827
828static int
829num_ge (num a, num b)
830{
831 return !num_lt (a, b);
832}
833
834static int
835num_lt (num a, num b)
836{
837 int ret;
838 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
839
840 if (is_fixnum)
841 ret = num_get_ivalue (a) < num_get_ivalue (b);
842 else
843 ret = num_get_rvalue (a) < num_get_rvalue (b);
844
845 return ret;
846}
847
848static int
849num_le (num a, num b)
850{
851 return !num_gt (a, b);
852}
853
854#if USE_MATH
855
856/* Round to nearest. Round to even if midway */
857static double
858round_per_R5RS (double x)
859{
860 double fl = floor (x);
861 double ce = ceil (x);
862 double dfl = x - fl;
863 double dce = ce - x;
864
865 if (dfl > dce)
866 return ce;
867 else if (dfl < dce)
868 return fl;
869 else
870 {
871 if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */
872 return fl;
873 else
874 return ce;
875 }
876}
877#endif
878 873
879static int 874static int
880is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
881{ 876{
877 return x == 0;
878#if 0
882#if USE_REAL 879#if USE_REAL
883 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 880 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
884#else 881#else
885 return x == 0; 882 return x == 0;
886#endif 883#endif
884#endif
887} 885}
888 886
889/* allocate new cell segment */ 887/* allocate new cell segment */
890static int 888ecb_cold static int
891alloc_cellseg (SCHEME_P_ int n) 889alloc_cellseg (SCHEME_P)
892{ 890{
893 pointer newp; 891 struct cell *newp;
894 pointer last; 892 struct cell *last;
895 pointer p; 893 struct cell *p;
896 char *cp; 894 char *cp;
897 long i; 895 long i;
898 int k; 896 int k;
899 897
900 static int segsize = CELL_SEGSIZE >> 1; 898 static int segsize = CELL_SEGSIZE >> 1;
901 segsize <<= 1; 899 segsize <<= 1;
902 900
903 for (k = 0; k < n; k++)
904 {
905 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
906 return k;
907
908 cp = malloc (segsize * sizeof (struct cell)); 901 cp = malloc (segsize * sizeof (struct cell));
909 902
910 if (!cp && USE_ERROR_CHECKING) 903 if (!cp && USE_ERROR_CHECKING)
911 return k; 904 return k;
912 905
913 i = ++SCHEME_V->last_cell_seg; 906 i = ++SCHEME_V->last_cell_seg;
914 SCHEME_V->alloc_seg[i] = cp; 907 SCHEME_V->alloc_seg[i] = cp;
915 908
916 /* insert new segment in address order */ 909 newp = (struct cell *)cp;
917 newp = (pointer)cp;
918 SCHEME_V->cell_seg[i] = newp; 910 SCHEME_V->cell_seg[i] = newp;
919 SCHEME_V->cell_segsize[i] = segsize; 911 SCHEME_V->cell_segsize[i] = segsize;
920
921 //TODO: insert, not swap
922 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
923 {
924 p = SCHEME_V->cell_seg[i];
925 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
926 SCHEME_V->cell_seg[i - 1] = p;
927
928 k = SCHEME_V->cell_segsize[i];
929 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
930 SCHEME_V->cell_segsize[i - 1] = k;
931
932 --i;
933 }
934
935 SCHEME_V->fcells += segsize; 912 SCHEME_V->fcells += segsize;
936 last = newp + segsize - 1; 913 last = newp + segsize - 1;
937 914
938 for (p = newp; p <= last; p++) 915 for (p = newp; p <= last; p++)
939 { 916 {
917 pointer cp = POINTER (p);
940 set_typeflag (p, T_FREE); 918 set_typeflag (cp, T_PAIR);
941 set_car (p, NIL); 919 set_car (cp, NIL);
942 set_cdr (p, p + 1); 920 set_cdr (cp, POINTER (p + 1));
943 } 921 }
944 922
945 /* insert new cells in address order on free list */
946 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
947 {
948 set_cdr (last, SCHEME_V->free_cell); 923 set_cdr (POINTER (last), SCHEME_V->free_cell);
949 SCHEME_V->free_cell = newp; 924 SCHEME_V->free_cell = POINTER (newp);
950 }
951 else
952 {
953 p = SCHEME_V->free_cell;
954 925
955 while (cdr (p) != NIL && newp > cdr (p))
956 p = cdr (p);
957
958 set_cdr (last, cdr (p));
959 set_cdr (p, newp);
960 }
961 }
962
963 return n; 926 return 1;
964} 927}
965 928
966/* get new cell. parameter a, b is marked by gc. */ 929/* get new cell. parameter a, b is marked by gc. */
967static INLINE pointer 930ecb_inline pointer
968get_cell_x (SCHEME_P_ pointer a, pointer b) 931get_cell_x (SCHEME_P_ pointer a, pointer b)
969{ 932{
970 if (SCHEME_V->free_cell == NIL) 933 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
971 { 934 {
972 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
973 return S_SINK; 936 return S_SINK;
974 937
975 if (SCHEME_V->free_cell == NIL) 938 if (SCHEME_V->free_cell == NIL)
976 { 939 {
977 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
978 941
979 gc (SCHEME_A_ a, b); 942 gc (SCHEME_A_ a, b);
980 943
981 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
982 { 945 {
983 /* if only a few recovered, get more to avoid fruitless gc's */ 946 /* if only a few recovered, get more to avoid fruitless gc's */
984 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 947 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
985 { 948 {
986#if USE_ERROR_CHECKING 949#if USE_ERROR_CHECKING
987 SCHEME_V->no_memory = 1; 950 SCHEME_V->no_memory = 1;
988 return S_SINK; 951 return S_SINK;
989#endif 952#endif
… …
1001 } 964 }
1002} 965}
1003 966
1004/* To retain recent allocs before interpreter knows about them - 967/* To retain recent allocs before interpreter knows about them -
1005 Tehom */ 968 Tehom */
1006 969ecb_hot static void
1007static void
1008push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1009{ 971{
1010 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 972 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1011 973
1012 set_typeflag (holder, T_PAIR); 974 set_typeflag (holder, T_PAIR);
… …
1014 set_car (holder, recent); 976 set_car (holder, recent);
1015 set_cdr (holder, car (S_SINK)); 977 set_cdr (holder, car (S_SINK));
1016 set_car (S_SINK, holder); 978 set_car (S_SINK, holder);
1017} 979}
1018 980
1019static pointer 981ecb_hot static pointer
1020get_cell (SCHEME_P_ pointer a, pointer b) 982get_cell (SCHEME_P_ pointer a, pointer b)
1021{ 983{
1022 pointer cell = get_cell_x (SCHEME_A_ a, b); 984 pointer cell = get_cell_x (SCHEME_A_ a, b);
1023 985
1024 /* For right now, include "a" and "b" in "cell" so that gc doesn't 986 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1033} 995}
1034 996
1035static pointer 997static pointer
1036get_vector_object (SCHEME_P_ uint32_t len, pointer init) 998get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1037{ 999{
1038 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1000 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1039 pointer *e = malloc (len * sizeof (pointer)); 1001 pointer *e = malloc (len * sizeof (pointer));
1040 1002
1041 if (!e && USE_ERROR_CHECKING) 1003 if (!e && USE_ERROR_CHECKING)
1042 return S_SINK; 1004 return S_SINK;
1043 1005
1044 /* Record it as a vector so that gc understands it. */ 1006 /* Record it as a vector so that gc understands it. */
1045 set_typeflag (v, T_VECTOR | T_ATOM); 1007 set_typeflag (v, T_VECTOR | T_ATOM);
1046 1008
1047 v->object.vector.vvalue = e; 1009 CELL(v)->object.vector.vvalue = e;
1048 v->object.vector.length = len; 1010 CELL(v)->object.vector.length = len;
1049 fill_vector (v, init); 1011 fill_vector (v, 0, init);
1050 push_recent_alloc (SCHEME_A_ v, NIL); 1012 push_recent_alloc (SCHEME_A_ v, NIL);
1051 1013
1052 return v; 1014 return v;
1053} 1015}
1054 1016
1055static INLINE void 1017ecb_inline void
1056ok_to_freely_gc (SCHEME_P) 1018ok_to_freely_gc (SCHEME_P)
1057{ 1019{
1058 set_car (S_SINK, NIL); 1020 set_car (S_SINK, NIL);
1059} 1021}
1060 1022
… …
1062static void 1024static void
1063check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1064{ 1026{
1065 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1027 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1066 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1067 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1068 1030
1069 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1070 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1071} 1033}
1072 1034
1073static void 1035static void
1074check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1075{ 1037{
… …
1081#endif 1043#endif
1082 1044
1083/* Medium level cell allocation */ 1045/* Medium level cell allocation */
1084 1046
1085/* get new cons cell */ 1047/* get new cons cell */
1086pointer 1048ecb_hot pointer
1087xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1049xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1088{ 1050{
1089 pointer x = get_cell (SCHEME_A_ a, b); 1051 pointer x = get_cell (SCHEME_A_ a, b);
1090 1052
1091 set_typeflag (x, T_PAIR); 1053 set_typeflag (x, T_PAIR);
… …
1097 set_cdr (x, b); 1059 set_cdr (x, b);
1098 1060
1099 return x; 1061 return x;
1100} 1062}
1101 1063
1064ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name)
1066{
1067 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM);
1070 return x;
1071}
1072
1102/* ========== oblist implementation ========== */ 1073/* ========== oblist implementation ========== */
1103 1074
1104#ifndef USE_OBJECT_LIST 1075#ifndef USE_OBJECT_LIST
1105 1076
1077static int
1106static int hash_fn (const char *key, int table_size); 1078hash_fn (const char *key, int table_size)
1079{
1080 const unsigned char *p = key;
1081 uint32_t hash = 2166136261;
1107 1082
1083 while (*p)
1084 hash = (hash ^ *p++) * 16777619;
1085
1086 return hash % table_size;
1087}
1088
1108static pointer 1089ecb_cold static pointer
1109oblist_initial_value (SCHEME_P) 1090oblist_initial_value (SCHEME_P)
1110{ 1091{
1111 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1112} 1093}
1113 1094
1114/* returns the new symbol */ 1095/* returns the new symbol */
1115static pointer 1096ecb_cold static pointer
1116oblist_add_by_name (SCHEME_P_ const char *name) 1097oblist_add_by_name (SCHEME_P_ const char *name)
1117{ 1098{
1118 int location; 1099 pointer x = generate_symbol (SCHEME_A_ name);
1119
1120 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1121 set_typeflag (x, T_SYMBOL);
1122 setimmutable (car (x));
1123
1124 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1100 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1125 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1101 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1126 return x; 1102 return x;
1127} 1103}
1128 1104
1129static INLINE pointer 1105ecb_cold static pointer
1130oblist_find_by_name (SCHEME_P_ const char *name) 1106oblist_find_by_name (SCHEME_P_ const char *name)
1131{ 1107{
1132 int location; 1108 int location;
1133 pointer x; 1109 pointer x;
1134 char *s; 1110 char *s;
1135 1111
1136 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1112 location = hash_fn (name, veclength (SCHEME_V->oblist));
1137 1113
1138 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1114 for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1139 { 1115 {
1140 s = symname (car (x)); 1116 s = symname (car (x));
1141 1117
1142 /* case-insensitive, per R5RS section 2 */ 1118 /* case-insensitive, per R5RS section 2 */
1143 if (stricmp (name, s) == 0) 1119 if (stricmp (name, s) == 0)
… …
1145 } 1121 }
1146 1122
1147 return NIL; 1123 return NIL;
1148} 1124}
1149 1125
1150static pointer 1126ecb_cold static pointer
1151oblist_all_symbols (SCHEME_P) 1127oblist_all_symbols (SCHEME_P)
1152{ 1128{
1153 int i; 1129 int i;
1154 pointer x; 1130 pointer x;
1155 pointer ob_list = NIL; 1131 pointer ob_list = NIL;
1156 1132
1157 for (i = 0; i < veclength (SCHEME_V->oblist); i++) 1133 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1158 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1134 for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1159 ob_list = cons (x, ob_list); 1135 ob_list = cons (x, ob_list);
1160 1136
1161 return ob_list; 1137 return ob_list;
1162} 1138}
1163 1139
1164#else 1140#else
1165 1141
1166static pointer 1142ecb_cold static pointer
1167oblist_initial_value (SCHEME_P) 1143oblist_initial_value (SCHEME_P)
1168{ 1144{
1169 return NIL; 1145 return NIL;
1170} 1146}
1171 1147
1172static INLINE pointer 1148ecb_cold static pointer
1173oblist_find_by_name (SCHEME_P_ const char *name) 1149oblist_find_by_name (SCHEME_P_ const char *name)
1174{ 1150{
1175 pointer x; 1151 pointer x;
1176 char *s; 1152 char *s;
1177 1153
… …
1186 1162
1187 return NIL; 1163 return NIL;
1188} 1164}
1189 1165
1190/* returns the new symbol */ 1166/* returns the new symbol */
1191static pointer 1167ecb_cold static pointer
1192oblist_add_by_name (SCHEME_P_ const char *name) 1168oblist_add_by_name (SCHEME_P_ const char *name)
1193{ 1169{
1194 pointer x; 1170 pointer x = generate_symbol (SCHEME_A_ name);
1195
1196 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1197 set_typeflag (x, T_SYMBOL);
1198 setimmutable (car (x));
1199 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1200 return x; 1172 return x;
1201} 1173}
1202 1174
1203static pointer 1175ecb_cold static pointer
1204oblist_all_symbols (SCHEME_P) 1176oblist_all_symbols (SCHEME_P)
1205{ 1177{
1206 return SCHEME_V->oblist; 1178 return SCHEME_V->oblist;
1207} 1179}
1208 1180
1209#endif 1181#endif
1210 1182
1211#if USE_PORTS 1183#if USE_PORTS
1212static pointer 1184ecb_cold static pointer
1213mk_port (SCHEME_P_ port *p) 1185mk_port (SCHEME_P_ port *p)
1214{ 1186{
1215 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1187 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1216 1188
1217 set_typeflag (x, T_PORT | T_ATOM); 1189 set_typeflag (x, T_PORT | T_ATOM);
1218 x->object.port = p; 1190 set_port (x, p);
1219 1191
1220 return x; 1192 return x;
1221} 1193}
1222#endif 1194#endif
1223 1195
1224pointer 1196ecb_cold pointer
1225mk_foreign_func (SCHEME_P_ foreign_func f) 1197mk_foreign_func (SCHEME_P_ foreign_func f)
1226{ 1198{
1227 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1199 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1228 1200
1229 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1201 set_typeflag (x, T_FOREIGN | T_ATOM);
1230 x->object.ff = f; 1202 CELL(x)->object.ff = f;
1231 1203
1232 return x; 1204 return x;
1233} 1205}
1234 1206
1235INTERFACE pointer 1207INTERFACE pointer
1236mk_character (SCHEME_P_ int c) 1208mk_character (SCHEME_P_ int c)
1237{ 1209{
1238 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1210 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1239 1211
1240 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1212 set_typeflag (x, T_CHARACTER | T_ATOM);
1241 ivalue_unchecked (x) = c & 0xff; 1213 set_ivalue (x, c & 0xff);
1242 set_num_integer (x); 1214
1243 return x; 1215 return x;
1244} 1216}
1245 1217
1246/* get number atom (integer) */ 1218/* get number atom (integer) */
1247INTERFACE pointer 1219INTERFACE pointer
1248mk_integer (SCHEME_P_ long num) 1220mk_integer (SCHEME_P_ long n)
1249{ 1221{
1222 pointer p = 0;
1223 pointer *pp = &p;
1224
1225#if USE_INTCACHE
1226 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1227 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1228#endif
1229
1230 if (!*pp)
1231 {
1250 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1232 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1251 1233
1252 set_typeflag (x, (T_NUMBER | T_ATOM)); 1234 set_typeflag (x, T_INTEGER | T_ATOM);
1253 ivalue_unchecked (x) = num; 1235 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1254 set_num_integer (x); 1236 set_ivalue (x, n);
1237
1238 *pp = x;
1239 }
1240
1255 return x; 1241 return *pp;
1256} 1242}
1257 1243
1258INTERFACE pointer 1244INTERFACE pointer
1259mk_real (SCHEME_P_ RVALUE n) 1245mk_real (SCHEME_P_ RVALUE n)
1260{ 1246{
1247#if USE_REAL
1261 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1248 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1262 1249
1263 set_typeflag (x, (T_NUMBER | T_ATOM)); 1250 set_typeflag (x, T_REAL | T_ATOM);
1264 rvalue_unchecked (x) = n; 1251 set_rvalue (x, n);
1265 set_num_real (x); 1252
1266 return x; 1253 return x;
1254#else
1255 return mk_integer (SCHEME_A_ n);
1256#endif
1267} 1257}
1268 1258
1269static pointer 1259static pointer
1270mk_number (SCHEME_P_ const num n) 1260mk_number (SCHEME_P_ const num n)
1271{ 1261{
1262#if USE_REAL
1272 if (num_is_fixnum (n)) 1263 return num_is_fixnum (n)
1264 ? mk_integer (SCHEME_A_ num_ivalue (n))
1265 : mk_real (SCHEME_A_ num_rvalue (n));
1266#else
1273 return mk_integer (SCHEME_A_ num_get_ivalue (n)); 1267 return mk_integer (SCHEME_A_ num_ivalue (n));
1274 else 1268#endif
1275 return mk_real (SCHEME_A_ num_get_rvalue (n));
1276} 1269}
1277 1270
1278/* allocate name to string area */ 1271/* allocate name to string area */
1279static char * 1272static char *
1280store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill) 1273store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
… …
1286 SCHEME_V->no_memory = 1; 1279 SCHEME_V->no_memory = 1;
1287 return SCHEME_V->strbuff; 1280 return SCHEME_V->strbuff;
1288 } 1281 }
1289 1282
1290 if (str) 1283 if (str)
1291 { 1284 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1292 int l = strlen (str);
1293
1294 if (l > len_str)
1295 l = len_str;
1296
1297 memcpy (q, str, l);
1298 q[l] = 0;
1299 }
1300 else 1285 else
1301 {
1302 memset (q, fill, len_str); 1286 memset (q, fill, len_str);
1287
1303 q[len_str] = 0; 1288 q[len_str] = 0;
1304 }
1305 1289
1306 return q; 1290 return q;
1307} 1291}
1308 1292
1309INTERFACE pointer 1293INTERFACE pointer
… …
1323 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1307 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1324 1308
1325 set_typeflag (x, T_STRING | T_ATOM); 1309 set_typeflag (x, T_STRING | T_ATOM);
1326 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1310 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1327 strlength (x) = len; 1311 strlength (x) = len;
1312
1328 return x; 1313 return x;
1329} 1314}
1330 1315
1331INTERFACE pointer 1316INTERFACE pointer
1332mk_string (SCHEME_P_ const char *str) 1317mk_string (SCHEME_P_ const char *str)
… …
1339{ 1324{
1340 return get_vector_object (SCHEME_A_ len, NIL); 1325 return get_vector_object (SCHEME_A_ len, NIL);
1341} 1326}
1342 1327
1343INTERFACE void 1328INTERFACE void
1344fill_vector (pointer vec, pointer obj) 1329fill_vector (pointer vec, uint32_t start, pointer obj)
1345{ 1330{
1346 int i; 1331 int i;
1347 1332
1348 for (i = 0; i < vec->object.vector.length; i++) 1333 for (i = start; i < veclength (vec); i++)
1349 vecvalue (vec)[i] = obj; 1334 vecvalue (vec)[i] = obj;
1350} 1335}
1351 1336
1337INTERFACE void
1338vector_resize (pointer vec, uint32_t newsize, pointer fill)
1339{
1340 uint32_t oldsize = veclength (vec);
1341 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1342 veclength (vec) = newsize;
1343 fill_vector (vec, oldsize, fill);
1344}
1345
1352INTERFACE pointer 1346INTERFACE pointer
1353vector_elem (pointer vec, uint32_t ielem) 1347vector_get (pointer vec, uint32_t ielem)
1354{ 1348{
1355 return vecvalue(vec)[ielem]; 1349 return vecvalue(vec)[ielem];
1356} 1350}
1357 1351
1358INTERFACE void 1352INTERFACE void
1359set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1353vector_set (pointer vec, uint32_t ielem, pointer a)
1360{ 1354{
1361 vecvalue(vec)[ielem] = a; 1355 vecvalue(vec)[ielem] = a;
1362} 1356}
1363 1357
1364/* get new symbol */ 1358/* get new symbol */
… …
1372 x = oblist_add_by_name (SCHEME_A_ name); 1366 x = oblist_add_by_name (SCHEME_A_ name);
1373 1367
1374 return x; 1368 return x;
1375} 1369}
1376 1370
1377INTERFACE pointer 1371ecb_cold INTERFACE pointer
1378gensym (SCHEME_P) 1372gensym (SCHEME_P)
1379{ 1373{
1380 pointer x; 1374 pointer x;
1381
1382 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1383 {
1384 char name[40] = "gensym-"; 1375 char name[40] = "gensym-";
1385 xnum (name + 7, SCHEME_V->gensym_cnt); 1376 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1386 1377
1387 /* first check oblist */ 1378 return generate_symbol (SCHEME_A_ name);
1388 x = oblist_find_by_name (SCHEME_A_ name); 1379}
1389 1380
1390 if (x == NIL) 1381static int
1391 { 1382is_gensym (SCHEME_P_ pointer x)
1392 x = oblist_add_by_name (SCHEME_A_ name); 1383{
1393 return x; 1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1394 }
1395 }
1396
1397 return NIL;
1398} 1385}
1399 1386
1400/* make symbol or number atom from string */ 1387/* make symbol or number atom from string */
1401static pointer 1388ecb_cold static pointer
1402mk_atom (SCHEME_P_ char *q) 1389mk_atom (SCHEME_P_ char *q)
1403{ 1390{
1404 char c, *p; 1391 char c, *p;
1405 int has_dec_point = 0; 1392 int has_dec_point = 0;
1406 int has_fp_exp = 0; 1393 int has_fp_exp = 0;
… …
1456 } 1443 }
1457 else if ((c == 'e') || (c == 'E')) 1444 else if ((c == 'e') || (c == 'E'))
1458 { 1445 {
1459 if (!has_fp_exp) 1446 if (!has_fp_exp)
1460 { 1447 {
1461 has_dec_point = 1; /* decimal point illegal 1448 has_dec_point = 1; /* decimal point illegal from now on */
1462 from now on */
1463 p++; 1449 p++;
1464 1450
1465 if ((*p == '-') || (*p == '+') || isdigit (*p)) 1451 if ((*p == '-') || (*p == '+') || isdigit (*p))
1466 continue; 1452 continue;
1467 } 1453 }
… …
1478 1464
1479 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1480} 1466}
1481 1467
1482/* make constant */ 1468/* make constant */
1483static pointer 1469ecb_cold static pointer
1484mk_sharp_const (SCHEME_P_ char *name) 1470mk_sharp_const (SCHEME_P_ char *name)
1485{ 1471{
1486 if (!strcmp (name, "t")) 1472 if (!strcmp (name, "t"))
1487 return S_T; 1473 return S_T;
1488 else if (!strcmp (name, "f")) 1474 else if (!strcmp (name, "f"))
1489 return S_F; 1475 return S_F;
1490 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1491 { 1477 {
1492 int c; 1478 int c;
1493 1479
1480 // TODO: optimise
1494 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1495 c = ' '; 1482 c = ' ';
1496 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1497 c = '\n'; 1484 c = '\n';
1498 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1499 c = '\r'; 1486 c = '\r';
1500 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1501 c = '\t'; 1488 c = '\t';
1489 else if (stricmp (name + 1, "alarm") == 0)
1490 c = 0x07;
1491 else if (stricmp (name + 1, "backspace") == 0)
1492 c = 0x08;
1493 else if (stricmp (name + 1, "escape") == 0)
1494 c = 0x1b;
1495 else if (stricmp (name + 1, "delete") == 0)
1496 c = 0x7f;
1497 else if (stricmp (name + 1, "null") == 0)
1498 c = 0;
1502 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1503 { 1500 {
1504 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1505 1502
1506 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1532 } 1529 }
1533} 1530}
1534 1531
1535/* ========== garbage collector ========== */ 1532/* ========== garbage collector ========== */
1536 1533
1534static void
1535finalize_cell (SCHEME_P_ pointer a)
1536{
1537 /* TODO, fast bitmap check? */
1538 if (is_string (a) || is_symbol (a))
1539 free (strvalue (a));
1540 else if (is_vector (a))
1541 free (vecvalue (a));
1542#if USE_PORTS
1543 else if (is_port (a))
1544 {
1545 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1546 port_close (SCHEME_A_ a, port_input | port_output);
1547
1548 free (port (a));
1549 }
1550#endif
1551}
1552
1537/*-- 1553/*--
1538 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1554 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1539 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1555 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1540 * for marking. 1556 * for marking.
1557 *
1558 * The exception is vectors - vectors are currently marked recursively,
1559 * which is inherited form tinyscheme and could be fixed by having another
1560 * word of context in the vector
1541 */ 1561 */
1542static void 1562ecb_hot static void
1543mark (pointer a) 1563mark (pointer a)
1544{ 1564{
1545 pointer t, q, p; 1565 pointer t, q, p;
1546 1566
1547 t = 0; 1567 t = 0;
1548 p = a; 1568 p = a;
1549E2: 1569E2:
1550 setmark (p); 1570 setmark (p);
1551 1571
1552 if (is_vector (p)) 1572 if (ecb_expect_false (is_vector (p)))
1553 { 1573 {
1554 int i; 1574 int i;
1555 1575
1556 for (i = 0; i < p->object.vector.length; i++) 1576 for (i = 0; i < veclength (p); i++)
1557 mark (vecvalue (p)[i]); 1577 mark (vecvalue (p)[i]);
1558 } 1578 }
1559 1579
1560 if (is_atom (p)) 1580 if (is_atom (p))
1561 goto E6; 1581 goto E6;
… …
1604 p = q; 1624 p = q;
1605 goto E6; 1625 goto E6;
1606 } 1626 }
1607} 1627}
1608 1628
1629ecb_hot static void
1630gc_free (SCHEME_P)
1631{
1632 int i;
1633 uint32_t total = 0;
1634
1635 /* Here we scan the cells to build the free-list. */
1636 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1637 {
1638 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1639 struct cell *p;
1640 total += SCHEME_V->cell_segsize [i];
1641
1642 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1643 {
1644 pointer c = POINTER (p);
1645
1646 if (is_mark (c))
1647 clrmark (c);
1648 else
1649 {
1650 /* reclaim cell */
1651 if (typeflag (c) != T_PAIR)
1652 {
1653 finalize_cell (SCHEME_A_ c);
1654 set_typeflag (c, T_PAIR);
1655 set_car (c, NIL);
1656 }
1657
1658 ++SCHEME_V->fcells;
1659 set_cdr (c, SCHEME_V->free_cell);
1660 SCHEME_V->free_cell = c;
1661 }
1662 }
1663 }
1664
1665 if (SCHEME_V->gc_verbose)
1666 {
1667 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1668 }
1669}
1670
1609/* garbage collection. parameter a, b is marked. */ 1671/* garbage collection. parameter a, b is marked. */
1610static void 1672ecb_cold static void
1611gc (SCHEME_P_ pointer a, pointer b) 1673gc (SCHEME_P_ pointer a, pointer b)
1612{ 1674{
1613 pointer p;
1614 int i; 1675 int i;
1615 1676
1616 if (SCHEME_V->gc_verbose) 1677 if (SCHEME_V->gc_verbose)
1617 putstr (SCHEME_A_ "gc..."); 1678 putstr (SCHEME_A_ "gc...");
1618 1679
… …
1634 /* Mark recent objects the interpreter doesn't know about yet. */ 1695 /* Mark recent objects the interpreter doesn't know about yet. */
1635 mark (car (S_SINK)); 1696 mark (car (S_SINK));
1636 /* Mark any older stuff above nested C calls */ 1697 /* Mark any older stuff above nested C calls */
1637 mark (SCHEME_V->c_nest); 1698 mark (SCHEME_V->c_nest);
1638 1699
1700#if USE_INTCACHE
1701 /* mark intcache */
1702 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1703 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1704 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1705#endif
1706
1639 /* mark variables a, b */ 1707 /* mark variables a, b */
1640 mark (a); 1708 mark (a);
1641 mark (b); 1709 mark (b);
1642 1710
1643 /* garbage collect */ 1711 /* garbage collect */
1644 clrmark (NIL); 1712 clrmark (NIL);
1645 SCHEME_V->fcells = 0; 1713 SCHEME_V->fcells = 0;
1646 SCHEME_V->free_cell = NIL; 1714 SCHEME_V->free_cell = NIL;
1647 1715
1648 /* free-list is kept sorted by address so as to maintain consecutive
1649 ranges, if possible, for use with vectors. Here we scan the cells
1650 (which are also kept sorted by address) downwards to build the
1651 free-list in sorted order.
1652 */
1653 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1654 {
1655 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1656
1657 while (--p >= SCHEME_V->cell_seg[i])
1658 {
1659 if (is_mark (p))
1660 clrmark (p);
1661 else
1662 {
1663 /* reclaim cell */
1664 if (typeflag (p) != T_FREE)
1665 {
1666 finalize_cell (SCHEME_A_ p);
1667 set_typeflag (p, T_FREE);
1668 set_car (p, NIL);
1669 }
1670
1671 ++SCHEME_V->fcells;
1672 set_cdr (p, SCHEME_V->free_cell);
1673 SCHEME_V->free_cell = p;
1674 }
1675 }
1676 }
1677
1678 if (SCHEME_V->gc_verbose) 1716 if (SCHEME_V->gc_verbose)
1679 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1717 putstr (SCHEME_A_ "freeing...");
1680}
1681 1718
1682static void 1719 gc_free (SCHEME_A);
1683finalize_cell (SCHEME_P_ pointer a)
1684{
1685 if (is_string (a))
1686 free (strvalue (a));
1687 else if (is_vector (a))
1688 free (vecvalue (a));
1689#if USE_PORTS
1690 else if (is_port (a))
1691 {
1692 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1693 port_close (SCHEME_A_ a, port_input | port_output);
1694
1695 free (a->object.port);
1696 }
1697#endif
1698} 1720}
1699 1721
1700/* ========== Routines for Reading ========== */ 1722/* ========== Routines for Reading ========== */
1701 1723
1702static int 1724ecb_cold static int
1703file_push (SCHEME_P_ const char *fname) 1725file_push (SCHEME_P_ const char *fname)
1704{ 1726{
1705#if USE_PORTS 1727#if USE_PORTS
1706 int fin; 1728 int fin;
1707 1729
… …
1716 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1738 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1717 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1739 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1718 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1740 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1719 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1741 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1720 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1742 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1721 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1743 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1722 1744
1723#if SHOW_ERROR_LINE 1745#if SHOW_ERROR_LINE
1724 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1746 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1725 1747
1726 if (fname) 1748 if (fname)
… …
1733#else 1755#else
1734 return 1; 1756 return 1;
1735#endif 1757#endif
1736} 1758}
1737 1759
1738static void 1760ecb_cold static void
1739file_pop (SCHEME_P) 1761file_pop (SCHEME_P)
1740{ 1762{
1741 if (SCHEME_V->file_i != 0) 1763 if (SCHEME_V->file_i != 0)
1742 { 1764 {
1743 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1765 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1744#if USE_PORTS 1766#if USE_PORTS
1745 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1767 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1746#endif 1768#endif
1747 SCHEME_V->file_i--; 1769 SCHEME_V->file_i--;
1748 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1770 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1749 } 1771 }
1750} 1772}
1751 1773
1752static int 1774ecb_cold static int
1753file_interactive (SCHEME_P) 1775file_interactive (SCHEME_P)
1754{ 1776{
1755#if USE_PORTS 1777#if USE_PORTS
1756 return SCHEME_V->file_i == 0 1778 return SCHEME_V->file_i == 0
1757 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1779 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1758 && (SCHEME_V->inport->object.port->kind & port_file); 1780 && (port (SCHEME_V->inport)->kind & port_file);
1759#else 1781#else
1760 return 0; 1782 return 0;
1761#endif 1783#endif
1762} 1784}
1763 1785
1764#if USE_PORTS 1786#if USE_PORTS
1765static port * 1787ecb_cold static port *
1766port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1788port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1767{ 1789{
1768 int fd; 1790 int fd;
1769 int flags; 1791 int flags;
1770 char *rw; 1792 char *rw;
… …
1793# endif 1815# endif
1794 1816
1795 return pt; 1817 return pt;
1796} 1818}
1797 1819
1798static pointer 1820ecb_cold static pointer
1799port_from_filename (SCHEME_P_ const char *fn, int prop) 1821port_from_filename (SCHEME_P_ const char *fn, int prop)
1800{ 1822{
1801 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1823 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1802 1824
1803 if (!pt && USE_ERROR_CHECKING) 1825 if (!pt && USE_ERROR_CHECKING)
1804 return NIL; 1826 return NIL;
1805 1827
1806 return mk_port (SCHEME_A_ pt); 1828 return mk_port (SCHEME_A_ pt);
1807} 1829}
1808 1830
1809static port * 1831ecb_cold static port *
1810port_rep_from_file (SCHEME_P_ int f, int prop) 1832port_rep_from_file (SCHEME_P_ int f, int prop)
1811{ 1833{
1812 port *pt = malloc (sizeof *pt); 1834 port *pt = malloc (sizeof *pt);
1813 1835
1814 if (!pt && USE_ERROR_CHECKING) 1836 if (!pt && USE_ERROR_CHECKING)
… …
1819 pt->rep.stdio.file = f; 1841 pt->rep.stdio.file = f;
1820 pt->rep.stdio.closeit = 0; 1842 pt->rep.stdio.closeit = 0;
1821 return pt; 1843 return pt;
1822} 1844}
1823 1845
1824static pointer 1846ecb_cold static pointer
1825port_from_file (SCHEME_P_ int f, int prop) 1847port_from_file (SCHEME_P_ int f, int prop)
1826{ 1848{
1827 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1849 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1828 1850
1829 if (!pt && USE_ERROR_CHECKING) 1851 if (!pt && USE_ERROR_CHECKING)
1830 return NIL; 1852 return NIL;
1831 1853
1832 return mk_port (SCHEME_A_ pt); 1854 return mk_port (SCHEME_A_ pt);
1833} 1855}
1834 1856
1835static port * 1857ecb_cold static port *
1836port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1858port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1837{ 1859{
1838 port *pt = malloc (sizeof (port)); 1860 port *pt = malloc (sizeof (port));
1839 1861
1840 if (!pt && USE_ERROR_CHECKING) 1862 if (!pt && USE_ERROR_CHECKING)
… …
1846 pt->rep.string.curr = start; 1868 pt->rep.string.curr = start;
1847 pt->rep.string.past_the_end = past_the_end; 1869 pt->rep.string.past_the_end = past_the_end;
1848 return pt; 1870 return pt;
1849} 1871}
1850 1872
1851static pointer 1873ecb_cold static pointer
1852port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1874port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1853{ 1875{
1854 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1876 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1855 1877
1856 if (!pt && USE_ERROR_CHECKING) 1878 if (!pt && USE_ERROR_CHECKING)
… …
1859 return mk_port (SCHEME_A_ pt); 1881 return mk_port (SCHEME_A_ pt);
1860} 1882}
1861 1883
1862# define BLOCK_SIZE 256 1884# define BLOCK_SIZE 256
1863 1885
1864static port * 1886ecb_cold static port *
1865port_rep_from_scratch (SCHEME_P) 1887port_rep_from_scratch (SCHEME_P)
1866{ 1888{
1867 char *start; 1889 char *start;
1868 port *pt = malloc (sizeof (port)); 1890 port *pt = malloc (sizeof (port));
1869 1891
… …
1883 pt->rep.string.curr = start; 1905 pt->rep.string.curr = start;
1884 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1906 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1885 return pt; 1907 return pt;
1886} 1908}
1887 1909
1888static pointer 1910ecb_cold static pointer
1889port_from_scratch (SCHEME_P) 1911port_from_scratch (SCHEME_P)
1890{ 1912{
1891 port *pt = port_rep_from_scratch (SCHEME_A); 1913 port *pt = port_rep_from_scratch (SCHEME_A);
1892 1914
1893 if (!pt && USE_ERROR_CHECKING) 1915 if (!pt && USE_ERROR_CHECKING)
1894 return NIL; 1916 return NIL;
1895 1917
1896 return mk_port (SCHEME_A_ pt); 1918 return mk_port (SCHEME_A_ pt);
1897} 1919}
1898 1920
1899static void 1921ecb_cold static void
1900port_close (SCHEME_P_ pointer p, int flag) 1922port_close (SCHEME_P_ pointer p, int flag)
1901{ 1923{
1902 port *pt = p->object.port; 1924 port *pt = port (p);
1903 1925
1904 pt->kind &= ~flag; 1926 pt->kind &= ~flag;
1905 1927
1906 if ((pt->kind & (port_input | port_output)) == 0) 1928 if ((pt->kind & (port_input | port_output)) == 0)
1907 { 1929 {
… …
1928/* get new character from input file */ 1950/* get new character from input file */
1929static int 1951static int
1930inchar (SCHEME_P) 1952inchar (SCHEME_P)
1931{ 1953{
1932 int c; 1954 int c;
1933 port *pt; 1955 port *pt = port (SCHEME_V->inport);
1934
1935 pt = SCHEME_V->inport->object.port;
1936 1956
1937 if (pt->kind & port_saw_EOF) 1957 if (pt->kind & port_saw_EOF)
1938 return EOF; 1958 return EOF;
1939 1959
1940 c = basic_inchar (pt); 1960 c = basic_inchar (pt);
… …
2007 port *pt; 2027 port *pt;
2008 2028
2009 if (c == EOF) 2029 if (c == EOF)
2010 return; 2030 return;
2011 2031
2012 pt = SCHEME_V->inport->object.port; 2032 pt = port (SCHEME_V->inport);
2013 pt->unget = c; 2033 pt->unget = c;
2014#else 2034#else
2015 if (c == EOF) 2035 if (c == EOF)
2016 return; 2036 return;
2017 2037
2018 ungot = c; 2038 ungot = c;
2019#endif 2039#endif
2020} 2040}
2021 2041
2022#if USE_PORTS 2042#if USE_PORTS
2023static int 2043ecb_cold static int
2024realloc_port_string (SCHEME_P_ port *p) 2044realloc_port_string (SCHEME_P_ port *p)
2025{ 2045{
2026 char *start = p->rep.string.start; 2046 char *start = p->rep.string.start;
2027 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2047 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2028 char *str = malloc (new_size); 2048 char *str = malloc (new_size);
… …
2041 else 2061 else
2042 return 0; 2062 return 0;
2043} 2063}
2044#endif 2064#endif
2045 2065
2046INTERFACE void 2066ecb_cold INTERFACE void
2047putstr (SCHEME_P_ const char *s) 2067putstr (SCHEME_P_ const char *s)
2048{ 2068{
2049#if USE_PORTS 2069#if USE_PORTS
2050 port *pt = SCHEME_V->outport->object.port; 2070 port *pt = port (SCHEME_V->outport);
2051 2071
2052 if (pt->kind & port_file) 2072 if (pt->kind & port_file)
2053 write (pt->rep.stdio.file, s, strlen (s)); 2073 write (pt->rep.stdio.file, s, strlen (s));
2054 else 2074 else
2055 for (; *s; s++) 2075 for (; *s; s++)
… …
2057 *pt->rep.string.curr++ = *s; 2077 *pt->rep.string.curr++ = *s;
2058 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2078 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2059 *pt->rep.string.curr++ = *s; 2079 *pt->rep.string.curr++ = *s;
2060 2080
2061#else 2081#else
2062 xwrstr (s); 2082 write (pt->rep.stdio.file, s, strlen (s));
2063#endif 2083#endif
2064} 2084}
2065 2085
2066static void 2086ecb_cold static void
2067putchars (SCHEME_P_ const char *s, int len) 2087putchars (SCHEME_P_ const char *s, int len)
2068{ 2088{
2069#if USE_PORTS 2089#if USE_PORTS
2070 port *pt = SCHEME_V->outport->object.port; 2090 port *pt = port (SCHEME_V->outport);
2071 2091
2072 if (pt->kind & port_file) 2092 if (pt->kind & port_file)
2073 write (pt->rep.stdio.file, s, len); 2093 write (pt->rep.stdio.file, s, len);
2074 else 2094 else
2075 { 2095 {
… …
2085#else 2105#else
2086 write (1, s, len); 2106 write (1, s, len);
2087#endif 2107#endif
2088} 2108}
2089 2109
2090INTERFACE void 2110ecb_cold INTERFACE void
2091putcharacter (SCHEME_P_ int c) 2111putcharacter (SCHEME_P_ int c)
2092{ 2112{
2093#if USE_PORTS 2113#if USE_PORTS
2094 port *pt = SCHEME_V->outport->object.port; 2114 port *pt = port (SCHEME_V->outport);
2095 2115
2096 if (pt->kind & port_file) 2116 if (pt->kind & port_file)
2097 { 2117 {
2098 char cc = c; 2118 char cc = c;
2099 write (pt->rep.stdio.file, &cc, 1); 2119 write (pt->rep.stdio.file, &cc, 1);
… …
2111 write (1, &c, 1); 2131 write (1, &c, 1);
2112#endif 2132#endif
2113} 2133}
2114 2134
2115/* read characters up to delimiter, but cater to character constants */ 2135/* read characters up to delimiter, but cater to character constants */
2116static char * 2136ecb_cold static char *
2117readstr_upto (SCHEME_P_ char *delim) 2137readstr_upto (SCHEME_P_ int skip, const char *delim)
2118{ 2138{
2119 char *p = SCHEME_V->strbuff; 2139 char *p = SCHEME_V->strbuff + skip;
2120 2140
2121 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2141 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2122 2142
2123 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2143 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2124 *p = 0; 2144 *p = 0;
… …
2130 2150
2131 return SCHEME_V->strbuff; 2151 return SCHEME_V->strbuff;
2132} 2152}
2133 2153
2134/* read string expression "xxx...xxx" */ 2154/* read string expression "xxx...xxx" */
2135static pointer 2155ecb_cold static pointer
2136readstrexp (SCHEME_P) 2156readstrexp (SCHEME_P_ char delim)
2137{ 2157{
2138 char *p = SCHEME_V->strbuff; 2158 char *p = SCHEME_V->strbuff;
2139 int c; 2159 int c;
2140 int c1 = 0; 2160 int c1 = 0;
2141 enum
2142 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2161 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2143 2162
2144 for (;;) 2163 for (;;)
2145 { 2164 {
2146 c = inchar (SCHEME_A); 2165 c = inchar (SCHEME_A);
2147 2166
… …
2149 return S_F; 2168 return S_F;
2150 2169
2151 switch (state) 2170 switch (state)
2152 { 2171 {
2153 case st_ok: 2172 case st_ok:
2154 switch (c) 2173 if (ecb_expect_false (c == delim))
2155 {
2156 case '\\':
2157 state = st_bsl;
2158 break;
2159
2160 case '"':
2161 *p = 0;
2162 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2174 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2163 2175
2164 default: 2176 if (ecb_expect_false (c == '\\'))
2177 state = st_bsl;
2178 else
2165 *p++ = c; 2179 *p++ = c;
2166 break;
2167 }
2168 2180
2169 break; 2181 break;
2170 2182
2171 case st_bsl: 2183 case st_bsl:
2172 switch (c) 2184 switch (c)
… …
2181 case '7': 2193 case '7':
2182 state = st_oct1; 2194 state = st_oct1;
2183 c1 = c - '0'; 2195 c1 = c - '0';
2184 break; 2196 break;
2185 2197
2198 case 'a': *p++ = '\a'; state = st_ok; break;
2199 case 'n': *p++ = '\n'; state = st_ok; break;
2200 case 'r': *p++ = '\r'; state = st_ok; break;
2201 case 't': *p++ = '\t'; state = st_ok; break;
2202
2203 //TODO: \whitespace eol whitespace
2204
2205 //TODO: x should end in ;, not two-digit hex
2186 case 'x': 2206 case 'x':
2187 case 'X': 2207 case 'X':
2188 state = st_x1; 2208 state = st_x1;
2189 c1 = 0; 2209 c1 = 0;
2190 break; 2210 break;
2191 2211
2192 case 'n':
2193 *p++ = '\n';
2194 state = st_ok;
2195 break;
2196
2197 case 't':
2198 *p++ = '\t';
2199 state = st_ok;
2200 break;
2201
2202 case 'r':
2203 *p++ = '\r';
2204 state = st_ok;
2205 break;
2206
2207 case '"':
2208 *p++ = '"';
2209 state = st_ok;
2210 break;
2211
2212 default: 2212 default:
2213 *p++ = c; 2213 *p++ = c;
2214 state = st_ok; 2214 state = st_ok;
2215 break; 2215 break;
2216 } 2216 }
2217 2217
2218 break; 2218 break;
2219 2219
2220 case st_x1: 2220 case st_x1:
2221 case st_x2: 2221 case st_x2:
2222 c = toupper (c); 2222 c = tolower (c);
2223 2223
2224 if (c >= '0' && c <= 'F') 2224 if (c >= '0' && c <= '9')
2225 {
2226 if (c <= '9')
2227 c1 = (c1 << 4) + c - '0'; 2225 c1 = (c1 << 4) + c - '0';
2228 else 2226 else if (c >= 'a' && c <= 'f')
2229 c1 = (c1 << 4) + c - 'A' + 10; 2227 c1 = (c1 << 4) + c - 'a' + 10;
2230
2231 if (state == st_x1)
2232 state = st_x2;
2233 else
2234 {
2235 *p++ = c1;
2236 state = st_ok;
2237 }
2238 }
2239 else 2228 else
2240 return S_F; 2229 return S_F;
2230
2231 if (state == st_x1)
2232 state = st_x2;
2233 else
2234 {
2235 *p++ = c1;
2236 state = st_ok;
2237 }
2241 2238
2242 break; 2239 break;
2243 2240
2244 case st_oct1: 2241 case st_oct1:
2245 case st_oct2: 2242 case st_oct2:
… …
2249 backchar (SCHEME_A_ c); 2246 backchar (SCHEME_A_ c);
2250 state = st_ok; 2247 state = st_ok;
2251 } 2248 }
2252 else 2249 else
2253 { 2250 {
2254 if (state == st_oct2 && c1 >= 32) 2251 if (state == st_oct2 && c1 >= ' ')
2255 return S_F; 2252 return S_F;
2256 2253
2257 c1 = (c1 << 3) + (c - '0'); 2254 c1 = (c1 << 3) + (c - '0');
2258 2255
2259 if (state == st_oct1) 2256 if (state == st_oct1)
… …
2264 state = st_ok; 2261 state = st_ok;
2265 } 2262 }
2266 } 2263 }
2267 2264
2268 break; 2265 break;
2269
2270 } 2266 }
2271 } 2267 }
2272} 2268}
2273 2269
2274/* check c is in chars */ 2270/* check c is in chars */
2275static INLINE int 2271ecb_cold int
2276is_one_of (char *s, int c) 2272is_one_of (const char *s, int c)
2277{ 2273{
2278 if (c == EOF)
2279 return 1;
2280
2281 return !!strchr (s, c); 2274 return c == EOF || !!strchr (s, c);
2282} 2275}
2283 2276
2284/* skip white characters */ 2277/* skip white characters */
2285static INLINE int 2278ecb_cold int
2286skipspace (SCHEME_P) 2279skipspace (SCHEME_P)
2287{ 2280{
2288 int c, curr_line = 0; 2281 int c, curr_line = 0;
2289 2282
2290 do 2283 do
2291 { 2284 {
2292 c = inchar (SCHEME_A); 2285 c = inchar (SCHEME_A);
2286
2293#if SHOW_ERROR_LINE 2287#if SHOW_ERROR_LINE
2294 if (c == '\n') 2288 if (ecb_expect_false (c == '\n'))
2295 curr_line++; 2289 curr_line++;
2296#endif 2290#endif
2291
2292 if (ecb_expect_false (c == EOF))
2293 return c;
2297 } 2294 }
2298 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2295 while (is_one_of (WHITESPACE, c));
2299 2296
2300 /* record it */ 2297 /* record it */
2301#if SHOW_ERROR_LINE 2298#if SHOW_ERROR_LINE
2302 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2299 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2303 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2300 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2304#endif 2301#endif
2305 2302
2306 if (c != EOF)
2307 {
2308 backchar (SCHEME_A_ c); 2303 backchar (SCHEME_A_ c);
2309 return 1; 2304 return 1;
2310 }
2311 else
2312 return EOF;
2313} 2305}
2314 2306
2315/* get token */ 2307/* get token */
2316static int 2308ecb_cold static int
2317token (SCHEME_P) 2309token (SCHEME_P)
2318{ 2310{
2319 int c = skipspace (SCHEME_A); 2311 int c = skipspace (SCHEME_A);
2320 2312
2321 if (c == EOF) 2313 if (c == EOF)
… …
2333 return TOK_RPAREN; 2325 return TOK_RPAREN;
2334 2326
2335 case '.': 2327 case '.':
2336 c = inchar (SCHEME_A); 2328 c = inchar (SCHEME_A);
2337 2329
2338 if (is_one_of (" \n\t", c)) 2330 if (is_one_of (WHITESPACE, c))
2339 return TOK_DOT; 2331 return TOK_DOT;
2340 else 2332 else
2341 { 2333 {
2342 //TODO: ungetc twice in a row is not supported in C
2343 backchar (SCHEME_A_ c); 2334 backchar (SCHEME_A_ c);
2344 backchar (SCHEME_A_ '.');
2345 return TOK_ATOM; 2335 return TOK_DOTATOM;
2346 } 2336 }
2337
2338 case '|':
2339 return TOK_STRATOM;
2347 2340
2348 case '\'': 2341 case '\'':
2349 return TOK_QUOTE; 2342 return TOK_QUOTE;
2350 2343
2351 case ';': 2344 case ';':
… …
2418} 2411}
2419 2412
2420/* ========== Routines for Printing ========== */ 2413/* ========== Routines for Printing ========== */
2421#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2414#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2422 2415
2423static void 2416ecb_cold static void
2424printslashstring (SCHEME_P_ char *p, int len) 2417printslashstring (SCHEME_P_ char *p, int len)
2425{ 2418{
2426 int i; 2419 int i;
2427 unsigned char *s = (unsigned char *) p; 2420 unsigned char *s = (unsigned char *) p;
2428 2421
… …
2483 } 2476 }
2484 2477
2485 putcharacter (SCHEME_A_ '"'); 2478 putcharacter (SCHEME_A_ '"');
2486} 2479}
2487 2480
2488
2489/* print atoms */ 2481/* print atoms */
2490static void 2482ecb_cold static void
2491printatom (SCHEME_P_ pointer l, int f) 2483printatom (SCHEME_P_ pointer l, int f)
2492{ 2484{
2493 char *p; 2485 char *p;
2494 int len; 2486 int len;
2495 2487
2496 atom2str (SCHEME_A_ l, f, &p, &len); 2488 atom2str (SCHEME_A_ l, f, &p, &len);
2497 putchars (SCHEME_A_ p, len); 2489 putchars (SCHEME_A_ p, len);
2498} 2490}
2499 2491
2500
2501/* Uses internal buffer unless string pointer is already available */ 2492/* Uses internal buffer unless string pointer is already available */
2502static void 2493ecb_cold static void
2503atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2494atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2504{ 2495{
2505 char *p; 2496 char *p;
2506 2497
2507 if (l == NIL) 2498 if (l == NIL)
… …
2518 { 2509 {
2519 p = SCHEME_V->strbuff; 2510 p = SCHEME_V->strbuff;
2520 2511
2521 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2512 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2522 { 2513 {
2523 if (num_is_integer (l)) 2514 if (is_integer (l))
2524 xnum (p, ivalue_unchecked (l)); 2515 xnum (p, ivalue_unchecked (l));
2525#if USE_REAL 2516#if USE_REAL
2526 else 2517 else
2527 { 2518 {
2528 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2519 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
… …
2665#endif 2656#endif
2666 } 2657 }
2667 else if (is_continuation (l)) 2658 else if (is_continuation (l))
2668 p = "#<CONTINUATION>"; 2659 p = "#<CONTINUATION>";
2669 else 2660 else
2661 {
2662#if USE_PRINTF
2663 p = SCHEME_V->strbuff;
2664 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2665#else
2670 p = "#<ERROR>"; 2666 p = "#<ERROR>";
2667#endif
2668 }
2671 2669
2672 *pp = p; 2670 *pp = p;
2673 *plen = strlen (p); 2671 *plen = strlen (p);
2674} 2672}
2675 2673
… …
2707 return car (d); 2705 return car (d);
2708 2706
2709 p = cons (car (d), cdr (d)); 2707 p = cons (car (d), cdr (d));
2710 q = p; 2708 q = p;
2711 2709
2712 while (cdr (cdr (p)) != NIL) 2710 while (cddr (p) != NIL)
2713 { 2711 {
2714 d = cons (car (p), cdr (p)); 2712 d = cons (car (p), cdr (p));
2715 2713
2716 if (cdr (cdr (p)) != NIL) 2714 if (cddr (p) != NIL)
2717 p = cdr (d); 2715 p = cdr (d);
2718 } 2716 }
2719 2717
2720 set_cdr (p, car (cdr (p))); 2718 set_cdr (p, cadr (p));
2721 return q; 2719 return q;
2722} 2720}
2723 2721
2724/* reverse list -- produce new list */ 2722/* reverse list -- produce new list */
2725static pointer 2723ecb_hot static pointer
2726reverse (SCHEME_P_ pointer a) 2724reverse (SCHEME_P_ pointer a)
2727{ 2725{
2728 /* a must be checked by gc */ 2726 /* a must be checked by gc */
2729 pointer p = NIL; 2727 pointer p = NIL;
2730 2728
… …
2733 2731
2734 return p; 2732 return p;
2735} 2733}
2736 2734
2737/* reverse list --- in-place */ 2735/* reverse list --- in-place */
2738static pointer 2736ecb_hot static pointer
2739reverse_in_place (SCHEME_P_ pointer term, pointer list) 2737reverse_in_place (SCHEME_P_ pointer term, pointer list)
2740{ 2738{
2741 pointer result = term; 2739 pointer result = term;
2742 pointer p = list; 2740 pointer p = list;
2743 2741
… …
2751 2749
2752 return result; 2750 return result;
2753} 2751}
2754 2752
2755/* append list -- produce new list (in reverse order) */ 2753/* append list -- produce new list (in reverse order) */
2756static pointer 2754ecb_hot static pointer
2757revappend (SCHEME_P_ pointer a, pointer b) 2755revappend (SCHEME_P_ pointer a, pointer b)
2758{ 2756{
2759 pointer result = a; 2757 pointer result = a;
2760 pointer p = b; 2758 pointer p = b;
2761 2759
… …
2770 2768
2771 return S_F; /* signal an error */ 2769 return S_F; /* signal an error */
2772} 2770}
2773 2771
2774/* equivalence of atoms */ 2772/* equivalence of atoms */
2775int 2773ecb_hot int
2776eqv (pointer a, pointer b) 2774eqv (pointer a, pointer b)
2777{ 2775{
2778 if (is_string (a)) 2776 if (is_string (a))
2779 { 2777 {
2780 if (is_string (b)) 2778 if (is_string (b))
… …
2783 return 0; 2781 return 0;
2784 } 2782 }
2785 else if (is_number (a)) 2783 else if (is_number (a))
2786 { 2784 {
2787 if (is_number (b)) 2785 if (is_number (b))
2788 if (num_is_integer (a) == num_is_integer (b))
2789 return num_eq (nvalue (a), nvalue (b)); 2786 return num_cmp (nvalue (a), nvalue (b)) == 0;
2790 2787
2791 return 0; 2788 return 0;
2792 } 2789 }
2793 else if (is_character (a)) 2790 else if (is_character (a))
2794 { 2791 {
… …
2820/* () is #t in R5RS */ 2817/* () is #t in R5RS */
2821#define is_true(p) ((p) != S_F) 2818#define is_true(p) ((p) != S_F)
2822#define is_false(p) ((p) == S_F) 2819#define is_false(p) ((p) == S_F)
2823 2820
2824/* ========== Environment implementation ========== */ 2821/* ========== Environment implementation ========== */
2825
2826#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2827
2828static int
2829hash_fn (const char *key, int table_size)
2830{
2831 const unsigned char *p = key;
2832 uint32_t hash = 2166136261;
2833
2834 while (*p)
2835 hash = (hash ^ *p++) * 16777619;
2836
2837 return hash % table_size;
2838}
2839#endif
2840 2822
2841#ifndef USE_ALIST_ENV 2823#ifndef USE_ALIST_ENV
2842 2824
2843/* 2825/*
2844 * In this implementation, each frame of the environment may be 2826 * In this implementation, each frame of the environment may be
… …
2861 2843
2862 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2844 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2863 setenvironment (SCHEME_V->envir); 2845 setenvironment (SCHEME_V->envir);
2864} 2846}
2865 2847
2866static INLINE void 2848static uint32_t
2849sym_hash (pointer sym, uint32_t size)
2850{
2851 uintptr_t ptr = (uintptr_t)sym;
2852
2853#if 0
2854 /* table size is prime, so why mix */
2855 ptr += ptr >> 32;
2856 ptr += ptr >> 16;
2857 ptr += ptr >> 8;
2858#endif
2859
2860 return ptr % size;
2861}
2862
2863ecb_inline void
2867new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2864new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2868{ 2865{
2869 pointer slot = immutable_cons (variable, value); 2866 pointer slot = immutable_cons (variable, value);
2870 2867
2871 if (is_vector (car (env))) 2868 if (is_vector (car (env)))
2872 { 2869 {
2873 int location = hash_fn (symname (variable), veclength (car (env))); 2870 int location = sym_hash (variable, veclength (car (env)));
2874
2875 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2871 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2876 } 2872 }
2877 else 2873 else
2878 set_car (env, immutable_cons (slot, car (env))); 2874 set_car (env, immutable_cons (slot, car (env)));
2879} 2875}
2880 2876
2881static pointer 2877ecb_hot static pointer
2882find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2878find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2883{ 2879{
2884 pointer x, y; 2880 pointer x, y;
2885 int location;
2886 2881
2887 for (x = env; x != NIL; x = cdr (x)) 2882 for (x = env; x != NIL; x = cdr (x))
2888 { 2883 {
2889 if (is_vector (car (x))) 2884 if (is_vector (car (x)))
2890 { 2885 {
2891 location = hash_fn (symname (hdl), veclength (car (x))); 2886 int location = sym_hash (hdl, veclength (car (x)));
2892 y = vector_elem (car (x), location); 2887 y = vector_get (car (x), location);
2893 } 2888 }
2894 else 2889 else
2895 y = car (x); 2890 y = car (x);
2896 2891
2897 for (; y != NIL; y = cdr (y)) 2892 for (; y != NIL; y = cdr (y))
2898 if (caar (y) == hdl) 2893 if (caar (y) == hdl)
2899 break; 2894 break;
2900 2895
2901 if (y != NIL) 2896 if (y != NIL)
2897 return car (y);
2898
2899 if (!all)
2902 break; 2900 break;
2903
2904 if (!all)
2905 return NIL;
2906 } 2901 }
2907
2908 if (x != NIL)
2909 return car (y);
2910 2902
2911 return NIL; 2903 return NIL;
2912} 2904}
2913 2905
2914#else /* USE_ALIST_ENV */ 2906#else /* USE_ALIST_ENV */
2915 2907
2916static INLINE void 2908static void
2917new_frame_in_env (SCHEME_P_ pointer old_env) 2909new_frame_in_env (SCHEME_P_ pointer old_env)
2918{ 2910{
2919 SCHEME_V->envir = immutable_cons (NIL, old_env); 2911 SCHEME_V->envir = immutable_cons (NIL, old_env);
2920 setenvironment (SCHEME_V->envir); 2912 setenvironment (SCHEME_V->envir);
2921} 2913}
2922 2914
2923static INLINE void 2915static void
2924new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2916new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2925{ 2917{
2926 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2918 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2927} 2919}
2928 2920
2929static pointer 2921ecb_hot static pointer
2930find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2922find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2931{ 2923{
2932 pointer x, y; 2924 pointer x, y;
2933 2925
2934 for (x = env; x != NIL; x = cdr (x)) 2926 for (x = env; x != NIL; x = cdr (x))
… …
2936 for (y = car (x); y != NIL; y = cdr (y)) 2928 for (y = car (x); y != NIL; y = cdr (y))
2937 if (caar (y) == hdl) 2929 if (caar (y) == hdl)
2938 break; 2930 break;
2939 2931
2940 if (y != NIL) 2932 if (y != NIL)
2933 return car (y);
2941 break; 2934 break;
2942 2935
2943 if (!all) 2936 if (!all)
2944 return NIL; 2937 break;
2945 } 2938 }
2946
2947 if (x != NIL)
2948 return car (y);
2949 2939
2950 return NIL; 2940 return NIL;
2951} 2941}
2952 2942
2953#endif /* USE_ALIST_ENV else */ 2943#endif /* USE_ALIST_ENV else */
2954 2944
2955static INLINE void 2945static void
2956new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2946new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2957{ 2947{
2948 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2958 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2949 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2959} 2950}
2960 2951
2961static INLINE void 2952static void
2962set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2953set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2963{ 2954{
2964 set_cdr (slot, value); 2955 set_cdr (slot, value);
2965} 2956}
2966 2957
2967static INLINE pointer 2958static pointer
2968slot_value_in_env (pointer slot) 2959slot_value_in_env (pointer slot)
2969{ 2960{
2970 return cdr (slot); 2961 return cdr (slot);
2971} 2962}
2972 2963
2973/* ========== Evaluation Cycle ========== */ 2964/* ========== Evaluation Cycle ========== */
2974 2965
2975static pointer 2966ecb_cold static int
2976xError_1 (SCHEME_P_ const char *s, pointer a) 2967xError_1 (SCHEME_P_ const char *s, pointer a)
2977{ 2968{
2978#if USE_ERROR_HOOK 2969#if USE_ERROR_HOOK
2979 pointer x; 2970 pointer x;
2980 pointer hdl = SCHEME_V->ERROR_HOOK; 2971 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3015 code = cons (mk_string (SCHEME_A_ s), code); 3006 code = cons (mk_string (SCHEME_A_ s), code);
3016 setimmutable (car (code)); 3007 setimmutable (car (code));
3017 SCHEME_V->code = cons (slot_value_in_env (x), code); 3008 SCHEME_V->code = cons (slot_value_in_env (x), code);
3018 SCHEME_V->op = OP_EVAL; 3009 SCHEME_V->op = OP_EVAL;
3019 3010
3020 return S_T; 3011 return 0;
3021 } 3012 }
3022#endif 3013#endif
3023 3014
3024 if (a) 3015 if (a)
3025 SCHEME_V->args = cons (a, NIL); 3016 SCHEME_V->args = cons (a, NIL);
… …
3027 SCHEME_V->args = NIL; 3018 SCHEME_V->args = NIL;
3028 3019
3029 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); 3020 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
3030 setimmutable (car (SCHEME_V->args)); 3021 setimmutable (car (SCHEME_V->args));
3031 SCHEME_V->op = OP_ERR0; 3022 SCHEME_V->op = OP_ERR0;
3023
3032 return S_T; 3024 return 0;
3033} 3025}
3034 3026
3035#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) 3027#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
3036#define Error_0(s) Error_1 (s, 0) 3028#define Error_0(s) Error_1 (s, 0)
3037 3029
3038/* Too small to turn into function */ 3030/* Too small to turn into function */
3039#define BEGIN do { 3031#define BEGIN do {
3040#define END } while (0) 3032#define END } while (0)
3041#define s_goto(a) BEGIN \ 3033#define s_goto(a) BEGIN \
3042 SCHEME_V->op = a; \ 3034 SCHEME_V->op = a; \
3043 return S_T; END 3035 return 0; END
3044 3036
3045#define s_return(a) return xs_return (SCHEME_A_ a) 3037#define s_return(a) return xs_return (SCHEME_A_ a)
3046 3038
3047#ifndef USE_SCHEME_STACK 3039#ifndef USE_SCHEME_STACK
3048 3040
… …
3055 pointer code; 3047 pointer code;
3056}; 3048};
3057 3049
3058# define STACK_GROWTH 3 3050# define STACK_GROWTH 3
3059 3051
3060static void 3052ecb_hot static void
3061s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3053s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3062{ 3054{
3063 int nframes = (uintptr_t)SCHEME_V->dump; 3055 int nframes = (uintptr_t)SCHEME_V->dump;
3064 struct dump_stack_frame *next_frame; 3056 struct dump_stack_frame *next_frame;
3065 3057
3066 /* enough room for the next frame? */ 3058 /* enough room for the next frame? */
3067 if (nframes >= SCHEME_V->dump_size) 3059 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3068 { 3060 {
3069 SCHEME_V->dump_size += STACK_GROWTH; 3061 SCHEME_V->dump_size += STACK_GROWTH;
3070 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3062 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3071 } 3063 }
3072 3064
3073 next_frame = SCHEME_V->dump_base + nframes; 3065 next_frame = SCHEME_V->dump_base + nframes;
3074 3066
3075 next_frame->op = op; 3067 next_frame->op = op;
3076 next_frame->args = args; 3068 next_frame->args = args;
3077 next_frame->envir = SCHEME_V->envir; 3069 next_frame->envir = SCHEME_V->envir;
3078 next_frame->code = code; 3070 next_frame->code = code;
3079 3071
3080 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3072 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3081} 3073}
3082 3074
3083static pointer 3075static ecb_hot int
3084xs_return (SCHEME_P_ pointer a) 3076xs_return (SCHEME_P_ pointer a)
3085{ 3077{
3086 int nframes = (uintptr_t)SCHEME_V->dump; 3078 int nframes = (uintptr_t)SCHEME_V->dump;
3087 struct dump_stack_frame *frame; 3079 struct dump_stack_frame *frame;
3088 3080
3089 SCHEME_V->value = a; 3081 SCHEME_V->value = a;
3090 3082
3091 if (nframes <= 0) 3083 if (nframes <= 0)
3092 return NIL; 3084 return -1;
3093 3085
3094 frame = &SCHEME_V->dump_base[--nframes]; 3086 frame = &SCHEME_V->dump_base[--nframes];
3095 SCHEME_V->op = frame->op; 3087 SCHEME_V->op = frame->op;
3096 SCHEME_V->args = frame->args; 3088 SCHEME_V->args = frame->args;
3097 SCHEME_V->envir = frame->envir; 3089 SCHEME_V->envir = frame->envir;
3098 SCHEME_V->code = frame->code; 3090 SCHEME_V->code = frame->code;
3099 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3091 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3100 3092
3101 return S_T; 3093 return 0;
3102} 3094}
3103 3095
3104static INLINE void 3096ecb_cold void
3105dump_stack_reset (SCHEME_P) 3097dump_stack_reset (SCHEME_P)
3106{ 3098{
3107 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3099 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3108 SCHEME_V->dump = (pointer)+0; 3100 SCHEME_V->dump = (pointer)+0;
3109} 3101}
3110 3102
3111static INLINE void 3103ecb_cold void
3112dump_stack_initialize (SCHEME_P) 3104dump_stack_initialize (SCHEME_P)
3113{ 3105{
3114 SCHEME_V->dump_size = 0; 3106 SCHEME_V->dump_size = 0;
3115 SCHEME_V->dump_base = 0; 3107 SCHEME_V->dump_base = 0;
3116 dump_stack_reset (SCHEME_A); 3108 dump_stack_reset (SCHEME_A);
3117} 3109}
3118 3110
3119static void 3111ecb_cold static void
3120dump_stack_free (SCHEME_P) 3112dump_stack_free (SCHEME_P)
3121{ 3113{
3122 free (SCHEME_V->dump_base); 3114 free (SCHEME_V->dump_base);
3123 SCHEME_V->dump_base = 0; 3115 SCHEME_V->dump_base = 0;
3124 SCHEME_V->dump = (pointer)0; 3116 SCHEME_V->dump = (pointer)0;
3125 SCHEME_V->dump_size = 0; 3117 SCHEME_V->dump_size = 0;
3126} 3118}
3127 3119
3128static void 3120ecb_cold static void
3129dump_stack_mark (SCHEME_P) 3121dump_stack_mark (SCHEME_P)
3130{ 3122{
3131 int nframes = (uintptr_t)SCHEME_V->dump; 3123 int nframes = (uintptr_t)SCHEME_V->dump;
3132 int i; 3124 int i;
3133 3125
… …
3139 mark (frame->envir); 3131 mark (frame->envir);
3140 mark (frame->code); 3132 mark (frame->code);
3141 } 3133 }
3142} 3134}
3143 3135
3144static pointer 3136ecb_cold static pointer
3145ss_get_cont (SCHEME_P) 3137ss_get_cont (SCHEME_P)
3146{ 3138{
3147 int nframes = (uintptr_t)SCHEME_V->dump; 3139 int nframes = (uintptr_t)SCHEME_V->dump;
3148 int i; 3140 int i;
3149 3141
… …
3161 } 3153 }
3162 3154
3163 return cont; 3155 return cont;
3164} 3156}
3165 3157
3166static void 3158ecb_cold static void
3167ss_set_cont (SCHEME_P_ pointer cont) 3159ss_set_cont (SCHEME_P_ pointer cont)
3168{ 3160{
3169 int i = 0; 3161 int i = 0;
3170 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3162 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3171 3163
3172 while (cont != NIL) 3164 while (cont != NIL)
3173 { 3165 {
3174 frame->op = ivalue (car (cont)); cont = cdr (cont); 3166 frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3175 frame->args = car (cont) ; cont = cdr (cont); 3167 frame->args = car (cont) ; cont = cdr (cont);
3176 frame->envir = car (cont) ; cont = cdr (cont); 3168 frame->envir = car (cont) ; cont = cdr (cont);
3177 frame->code = car (cont) ; cont = cdr (cont); 3169 frame->code = car (cont) ; cont = cdr (cont);
3178 3170
3179 ++frame; 3171 ++frame;
3180 ++i; 3172 ++i;
3181 } 3173 }
3182 3174
3183 SCHEME_V->dump = (pointer)(uintptr_t)i; 3175 SCHEME_V->dump = (pointer)(uintptr_t)i;
3184} 3176}
3185 3177
3186#else 3178#else
3187 3179
3188static INLINE void 3180ecb_cold void
3189dump_stack_reset (SCHEME_P) 3181dump_stack_reset (SCHEME_P)
3190{ 3182{
3191 SCHEME_V->dump = NIL; 3183 SCHEME_V->dump = NIL;
3192} 3184}
3193 3185
3194static INLINE void 3186ecb_cold void
3195dump_stack_initialize (SCHEME_P) 3187dump_stack_initialize (SCHEME_P)
3196{ 3188{
3197 dump_stack_reset (SCHEME_A); 3189 dump_stack_reset (SCHEME_A);
3198} 3190}
3199 3191
3200static void 3192ecb_cold static void
3201dump_stack_free (SCHEME_P) 3193dump_stack_free (SCHEME_P)
3202{ 3194{
3203 SCHEME_V->dump = NIL; 3195 SCHEME_V->dump = NIL;
3204} 3196}
3205 3197
3206static pointer 3198ecb_hot static int
3207xs_return (SCHEME_P_ pointer a) 3199xs_return (SCHEME_P_ pointer a)
3208{ 3200{
3209 pointer dump = SCHEME_V->dump; 3201 pointer dump = SCHEME_V->dump;
3210 3202
3211 SCHEME_V->value = a; 3203 SCHEME_V->value = a;
3212 3204
3213 if (dump == NIL) 3205 if (dump == NIL)
3214 return NIL; 3206 return -1;
3215 3207
3216 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); 3208 SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3217 SCHEME_V->args = car (dump) ; dump = cdr (dump); 3209 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3218 SCHEME_V->envir = car (dump) ; dump = cdr (dump); 3210 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3219 SCHEME_V->code = car (dump) ; dump = cdr (dump); 3211 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3220 3212
3221 SCHEME_V->dump = dump; 3213 SCHEME_V->dump = dump;
3222 3214
3223 return S_T; 3215 return 0;
3224} 3216}
3225 3217
3226static void 3218ecb_hot static void
3227s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3219s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3228{ 3220{
3229 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3221 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3230 cons (args, 3222 cons (args,
3231 cons (SCHEME_V->envir, 3223 cons (SCHEME_V->envir,
3232 cons (code, 3224 cons (code,
3233 SCHEME_V->dump)))); 3225 SCHEME_V->dump))));
3234} 3226}
3235 3227
3236static void 3228ecb_cold static void
3237dump_stack_mark (SCHEME_P) 3229dump_stack_mark (SCHEME_P)
3238{ 3230{
3239 mark (SCHEME_V->dump); 3231 mark (SCHEME_V->dump);
3240} 3232}
3241 3233
3242static pointer 3234ecb_cold static pointer
3243ss_get_cont (SCHEME_P) 3235ss_get_cont (SCHEME_P)
3244{ 3236{
3245 return SCHEME_V->dump; 3237 return SCHEME_V->dump;
3246} 3238}
3247 3239
3248static void 3240ecb_cold static void
3249ss_set_cont (SCHEME_P_ pointer cont) 3241ss_set_cont (SCHEME_P_ pointer cont)
3250{ 3242{
3251 SCHEME_V->dump = cont; 3243 SCHEME_V->dump = cont;
3252} 3244}
3253 3245
3254#endif 3246#endif
3255 3247
3256#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3248#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3257 3249
3250#if EXPERIMENT
3258static pointer 3251static int
3252debug (SCHEME_P_ int indent, pointer x)
3253{
3254 int c;
3255
3256 if (is_syntax (x))
3257 {
3258 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3259 return 8 + 8;
3260 }
3261
3262 if (x == NIL)
3263 {
3264 printf ("%*sNIL\n", indent, "");
3265 return 3;
3266 }
3267
3268 switch (type (x))
3269 {
3270 case T_INTEGER:
3271 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3272 return 32+8;
3273
3274 case T_SYMBOL:
3275 printf ("%*sS<%s>\n", indent, "", symname (x));
3276 return 24+8;
3277
3278 case T_CLOSURE:
3279 printf ("%*sS<%s>\n", indent, "", "closure");
3280 debug (SCHEME_A_ indent + 3, cdr(x));
3281 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3282
3283 case T_PAIR:
3284 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3285 c = debug (SCHEME_A_ indent + 3, car (x));
3286 c += debug (SCHEME_A_ indent + 3, cdr (x));
3287 return c + 1;
3288
3289 case T_PORT:
3290 printf ("%*sS<%s>\n", indent, "", "port");
3291 return 24+8;
3292
3293 case T_VECTOR:
3294 printf ("%*sS<%s>\n", indent, "", "vector");
3295 return 24+8;
3296
3297 case T_ENVIRONMENT:
3298 printf ("%*sS<%s>\n", indent, "", "environment");
3299 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3300
3301 default:
3302 printf ("unhandled type %d\n", type (x));
3303 break;
3304 }
3305}
3306#endif
3307
3308/* syntax, eval, core, ... */
3309ecb_hot static int
3259opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3310opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3260{ 3311{
3312 pointer args = SCHEME_V->args;
3261 pointer x, y; 3313 pointer x, y;
3262 3314
3263 switch (op) 3315 switch (op)
3264 { 3316 {
3317#if EXPERIMENT //D
3318 case OP_DEBUG:
3319 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3320 printf ("\n");
3321 s_return (S_T);
3322#endif
3265 case OP_LOAD: /* load */ 3323 case OP_LOAD: /* load */
3266 if (file_interactive (SCHEME_A)) 3324 if (file_interactive (SCHEME_A))
3267 { 3325 {
3268 xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n"); 3326 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3269 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args))); 3327 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3270 } 3328 }
3271 3329
3272 if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args)))) 3330 if (!file_push (SCHEME_A_ strvalue (car (args))))
3273 Error_1 ("unable to open", car (SCHEME_V->args)); 3331 Error_1 ("unable to open", car (args));
3274 else 3332 else
3275 { 3333 {
3276 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3334 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3277 s_goto (OP_T0LVL); 3335 s_goto (OP_T0LVL);
3278 } 3336 }
3279 3337
3280 case OP_T0LVL: /* top level */ 3338 case OP_T0LVL: /* top level */
3281 3339
3282 /* If we reached the end of file, this loop is done. */ 3340 /* If we reached the end of file, this loop is done. */
3283 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3341 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3284 { 3342 {
3285 if (SCHEME_V->file_i == 0) 3343 if (SCHEME_V->file_i == 0)
3286 { 3344 {
3287 SCHEME_V->args = NIL; 3345 SCHEME_V->args = NIL;
3288 s_goto (OP_QUIT); 3346 s_goto (OP_QUIT);
… …
3352 case OP_EVAL: /* main part of evaluation */ 3410 case OP_EVAL: /* main part of evaluation */
3353#if USE_TRACING 3411#if USE_TRACING
3354 if (SCHEME_V->tracing) 3412 if (SCHEME_V->tracing)
3355 { 3413 {
3356 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ 3414 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
3357 s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code); 3415 s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
3358 SCHEME_V->args = SCHEME_V->code; 3416 SCHEME_V->args = SCHEME_V->code;
3359 putstr (SCHEME_A_ "\nEval: "); 3417 putstr (SCHEME_A_ "\nEval: ");
3360 s_goto (OP_P0LIST); 3418 s_goto (OP_P0LIST);
3361 } 3419 }
3362 3420
… …
3366#endif 3424#endif
3367 if (is_symbol (SCHEME_V->code)) /* symbol */ 3425 if (is_symbol (SCHEME_V->code)) /* symbol */
3368 { 3426 {
3369 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3427 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3370 3428
3371 if (x != NIL) 3429 if (x == NIL)
3372 s_return (slot_value_in_env (x));
3373 else
3374 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3430 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3431
3432 s_return (slot_value_in_env (x));
3375 } 3433 }
3376 else if (is_pair (SCHEME_V->code)) 3434 else if (is_pair (SCHEME_V->code))
3377 { 3435 {
3378 x = car (SCHEME_V->code); 3436 x = car (SCHEME_V->code);
3379 3437
… …
3392 } 3450 }
3393 else 3451 else
3394 s_return (SCHEME_V->code); 3452 s_return (SCHEME_V->code);
3395 3453
3396 case OP_E0ARGS: /* eval arguments */ 3454 case OP_E0ARGS: /* eval arguments */
3397 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3455 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3398 { 3456 {
3399 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3457 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3400 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3458 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3401 SCHEME_V->code = SCHEME_V->value; 3459 SCHEME_V->code = SCHEME_V->value;
3402 s_goto (OP_APPLY); 3460 s_goto (OP_APPLY);
… …
3406 SCHEME_V->code = cdr (SCHEME_V->code); 3464 SCHEME_V->code = cdr (SCHEME_V->code);
3407 s_goto (OP_E1ARGS); 3465 s_goto (OP_E1ARGS);
3408 } 3466 }
3409 3467
3410 case OP_E1ARGS: /* eval arguments */ 3468 case OP_E1ARGS: /* eval arguments */
3411 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3469 args = cons (SCHEME_V->value, args);
3412 3470
3413 if (is_pair (SCHEME_V->code)) /* continue */ 3471 if (is_pair (SCHEME_V->code)) /* continue */
3414 { 3472 {
3415 s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code)); 3473 s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
3416 SCHEME_V->code = car (SCHEME_V->code); 3474 SCHEME_V->code = car (SCHEME_V->code);
3417 SCHEME_V->args = NIL; 3475 SCHEME_V->args = NIL;
3418 s_goto (OP_EVAL); 3476 s_goto (OP_EVAL);
3419 } 3477 }
3420 else /* end */ 3478 else /* end */
3421 { 3479 {
3422 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3480 args = reverse_in_place (SCHEME_A_ NIL, args);
3423 SCHEME_V->code = car (SCHEME_V->args); 3481 SCHEME_V->code = car (args);
3424 SCHEME_V->args = cdr (SCHEME_V->args); 3482 SCHEME_V->args = cdr (args);
3425 s_goto (OP_APPLY); 3483 s_goto (OP_APPLY);
3426 } 3484 }
3427 3485
3428#if USE_TRACING 3486#if USE_TRACING
3429 3487
3430 case OP_TRACING: 3488 case OP_TRACING:
3431 { 3489 {
3432 int tr = SCHEME_V->tracing; 3490 int tr = SCHEME_V->tracing;
3433 3491
3434 SCHEME_V->tracing = ivalue (car (SCHEME_V->args)); 3492 SCHEME_V->tracing = ivalue_unchecked (car (args));
3435 s_return (mk_integer (SCHEME_A_ tr)); 3493 s_return (mk_integer (SCHEME_A_ tr));
3436 } 3494 }
3437 3495
3438#endif 3496#endif
3439 3497
3440 case OP_APPLY: /* apply 'code' to 'args' */ 3498 case OP_APPLY: /* apply 'code' to 'args' */
3441#if USE_TRACING 3499#if USE_TRACING
3442 if (SCHEME_V->tracing) 3500 if (SCHEME_V->tracing)
3443 { 3501 {
3444 s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code); 3502 s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
3445 SCHEME_V->print_flag = 1; 3503 SCHEME_V->print_flag = 1;
3446 /* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */ 3504 /* args=cons(SCHEME_V->code,args); */
3447 putstr (SCHEME_A_ "\nApply to: "); 3505 putstr (SCHEME_A_ "\nApply to: ");
3448 s_goto (OP_P0LIST); 3506 s_goto (OP_P0LIST);
3449 } 3507 }
3450 3508
3451 /* fall through */ 3509 /* fall through */
3452 3510
3453 case OP_REAL_APPLY: 3511 case OP_REAL_APPLY:
3454#endif 3512#endif
3455 if (is_proc (SCHEME_V->code)) 3513 if (is_proc (SCHEME_V->code))
3456 {
3457 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3514 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3458 }
3459 else if (is_foreign (SCHEME_V->code)) 3515 else if (is_foreign (SCHEME_V->code))
3460 { 3516 {
3461 /* Keep nested calls from GC'ing the arglist */ 3517 /* Keep nested calls from GC'ing the arglist */
3462 push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL); 3518 push_recent_alloc (SCHEME_A_ args, NIL);
3463 x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args); 3519 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3464 3520
3465 s_return (x); 3521 s_return (x);
3466 } 3522 }
3467 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3523 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3468 { 3524 {
3469 /* Should not accept promise */ 3525 /* Should not accept promise */
3470 /* make environment */ 3526 /* make environment */
3471 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); 3527 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3472 3528
3473 for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) 3529 for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
3474 { 3530 {
3475 if (y == NIL) 3531 if (y == NIL)
3476 Error_0 ("not enough arguments"); 3532 Error_0 ("not enough arguments");
3477 else 3533 else
3478 new_slot_in_env (SCHEME_A_ car (x), car (y)); 3534 new_slot_in_env (SCHEME_A_ car (x), car (y));
… …
3496 s_goto (OP_BEGIN); 3552 s_goto (OP_BEGIN);
3497 } 3553 }
3498 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3554 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3499 { 3555 {
3500 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3556 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3501 s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL); 3557 s_return (args != NIL ? car (args) : NIL);
3502 } 3558 }
3503 else 3559 else
3504 Error_0 ("illegal function"); 3560 Error_0 ("illegal function");
3505 3561
3506 case OP_DOMACRO: /* do macro */ 3562 case OP_DOMACRO: /* do macro */
3507 SCHEME_V->code = SCHEME_V->value; 3563 SCHEME_V->code = SCHEME_V->value;
3508 s_goto (OP_EVAL); 3564 s_goto (OP_EVAL);
3509
3510#if 1
3511 3565
3512 case OP_LAMBDA: /* lambda */ 3566 case OP_LAMBDA: /* lambda */
3513 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3567 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3514 set SCHEME_V->value fall thru */ 3568 set SCHEME_V->value fall thru */
3515 { 3569 {
3516 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3570 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
3517 3571
3518 if (f != NIL) 3572 if (f != NIL)
3519 { 3573 {
3520 s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code); 3574 s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
3521 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3575 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3522 SCHEME_V->code = slot_value_in_env (f); 3576 SCHEME_V->code = slot_value_in_env (f);
3523 s_goto (OP_APPLY); 3577 s_goto (OP_APPLY);
3524 } 3578 }
3525 3579
3526 SCHEME_V->value = SCHEME_V->code; 3580 SCHEME_V->value = SCHEME_V->code;
3527 /* Fallthru */
3528 } 3581 }
3582 /* Fallthru */
3529 3583
3530 case OP_LAMBDA1: 3584 case OP_LAMBDA1:
3531 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3585 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3532 3586
3533#else
3534
3535 case OP_LAMBDA: /* lambda */
3536 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3537
3538#endif
3539
3540 case OP_MKCLOSURE: /* make-closure */ 3587 case OP_MKCLOSURE: /* make-closure */
3541 x = car (SCHEME_V->args); 3588 x = car (args);
3542 3589
3543 if (car (x) == SCHEME_V->LAMBDA) 3590 if (car (x) == SCHEME_V->LAMBDA)
3544 x = cdr (x); 3591 x = cdr (x);
3545 3592
3546 if (cdr (SCHEME_V->args) == NIL) 3593 if (cdr (args) == NIL)
3547 y = SCHEME_V->envir; 3594 y = SCHEME_V->envir;
3548 else 3595 else
3549 y = cadr (SCHEME_V->args); 3596 y = cadr (args);
3550 3597
3551 s_return (mk_closure (SCHEME_A_ x, y)); 3598 s_return (mk_closure (SCHEME_A_ x, y));
3552 3599
3553 case OP_QUOTE: /* quote */ 3600 case OP_QUOTE: /* quote */
3554 s_return (car (SCHEME_V->code)); 3601 s_return (car (SCHEME_V->code));
… …
3586 3633
3587 3634
3588 case OP_DEFP: /* defined? */ 3635 case OP_DEFP: /* defined? */
3589 x = SCHEME_V->envir; 3636 x = SCHEME_V->envir;
3590 3637
3591 if (cdr (SCHEME_V->args) != NIL) 3638 if (cdr (args) != NIL)
3592 x = cadr (SCHEME_V->args); 3639 x = cadr (args);
3593 3640
3594 s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); 3641 s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);
3595 3642
3596 case OP_SET0: /* set! */ 3643 case OP_SET0: /* set! */
3597 if (is_immutable (car (SCHEME_V->code))) 3644 if (is_immutable (car (SCHEME_V->code)))
3598 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code)); 3645 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));
3599 3646
… …
3630 3677
3631 case OP_IF1: /* if */ 3678 case OP_IF1: /* if */
3632 if (is_true (SCHEME_V->value)) 3679 if (is_true (SCHEME_V->value))
3633 SCHEME_V->code = car (SCHEME_V->code); 3680 SCHEME_V->code = car (SCHEME_V->code);
3634 else 3681 else
3635 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because 3682 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3636
3637 * car(NIL) = NIL */
3638 s_goto (OP_EVAL); 3683 s_goto (OP_EVAL);
3639 3684
3640 case OP_LET0: /* let */ 3685 case OP_LET0: /* let */
3641 SCHEME_V->args = NIL; 3686 SCHEME_V->args = NIL;
3642 SCHEME_V->value = SCHEME_V->code; 3687 SCHEME_V->value = SCHEME_V->code;
3643 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 3688 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3644 s_goto (OP_LET1); 3689 s_goto (OP_LET1);
3645 3690
3646 case OP_LET1: /* let (calculate parameters) */ 3691 case OP_LET1: /* let (calculate parameters) */
3647 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3692 args = cons (SCHEME_V->value, args);
3648 3693
3649 if (is_pair (SCHEME_V->code)) /* continue */ 3694 if (is_pair (SCHEME_V->code)) /* continue */
3650 { 3695 {
3651 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3696 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3652 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 3697 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3653 3698
3654 s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); 3699 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
3655 SCHEME_V->code = cadar (SCHEME_V->code); 3700 SCHEME_V->code = cadar (SCHEME_V->code);
3656 SCHEME_V->args = NIL; 3701 SCHEME_V->args = NIL;
3657 s_goto (OP_EVAL); 3702 s_goto (OP_EVAL);
3658 } 3703 }
3659 else /* end */ 3704 else /* end */
3660 { 3705 {
3661 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3706 args = reverse_in_place (SCHEME_A_ NIL, args);
3662 SCHEME_V->code = car (SCHEME_V->args); 3707 SCHEME_V->code = car (args);
3663 SCHEME_V->args = cdr (SCHEME_V->args); 3708 SCHEME_V->args = cdr (args);
3664 s_goto (OP_LET2); 3709 s_goto (OP_LET2);
3665 } 3710 }
3666 3711
3667 case OP_LET2: /* let */ 3712 case OP_LET2: /* let */
3668 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3713 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3669 3714
3670 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; 3715 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3671 y != NIL; x = cdr (x), y = cdr (y)) 3716 y != NIL; x = cdr (x), y = cdr (y))
3672 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3717 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3673 3718
3674 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3719 if (is_symbol (car (SCHEME_V->code))) /* named let */
3675 { 3720 {
3676 for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) 3721 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3677 { 3722 {
3678 if (!is_pair (x)) 3723 if (!is_pair (x))
3679 Error_1 ("Bad syntax of binding in let :", x); 3724 Error_1 ("Bad syntax of binding in let :", x);
3680 3725
3681 if (!is_list (SCHEME_A_ car (x))) 3726 if (!is_list (SCHEME_A_ car (x)))
3682 Error_1 ("Bad syntax of binding in let :", car (x)); 3727 Error_1 ("Bad syntax of binding in let :", car (x));
3683 3728
3684 SCHEME_V->args = cons (caar (x), SCHEME_V->args); 3729 args = cons (caar (x), args);
3685 } 3730 }
3686 3731
3687 x =
3688 mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)), 3732 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
3689 SCHEME_V->envir); 3733 SCHEME_V->envir);
3690 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); 3734 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
3691 SCHEME_V->code = cddr (SCHEME_V->code); 3735 SCHEME_V->code = cddr (SCHEME_V->code);
3692 SCHEME_V->args = NIL;
3693 } 3736 }
3694 else 3737 else
3695 { 3738 {
3696 SCHEME_V->code = cdr (SCHEME_V->code); 3739 SCHEME_V->code = cdr (SCHEME_V->code);
3740 }
3741
3697 SCHEME_V->args = NIL; 3742 SCHEME_V->args = NIL;
3698 }
3699
3700 s_goto (OP_BEGIN); 3743 s_goto (OP_BEGIN);
3701 3744
3702 case OP_LET0AST: /* let* */ 3745 case OP_LET0AST: /* let* */
3703 if (car (SCHEME_V->code) == NIL) 3746 if (car (SCHEME_V->code) == NIL)
3704 { 3747 {
… …
3722 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value); 3765 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
3723 SCHEME_V->code = cdr (SCHEME_V->code); 3766 SCHEME_V->code = cdr (SCHEME_V->code);
3724 3767
3725 if (is_pair (SCHEME_V->code)) /* continue */ 3768 if (is_pair (SCHEME_V->code)) /* continue */
3726 { 3769 {
3727 s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code); 3770 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3728 SCHEME_V->code = cadar (SCHEME_V->code); 3771 SCHEME_V->code = cadar (SCHEME_V->code);
3729 SCHEME_V->args = NIL; 3772 SCHEME_V->args = NIL;
3730 s_goto (OP_EVAL); 3773 s_goto (OP_EVAL);
3731 } 3774 }
3732 else /* end */ 3775 else /* end */
3733 { 3776 {
3734 SCHEME_V->code = SCHEME_V->args; 3777 SCHEME_V->code = args;
3735 SCHEME_V->args = NIL; 3778 SCHEME_V->args = NIL;
3736 s_goto (OP_BEGIN); 3779 s_goto (OP_BEGIN);
3737 } 3780 }
3738 3781
3739 case OP_LET0REC: /* letrec */ 3782 case OP_LET0REC: /* letrec */
… …
3742 SCHEME_V->value = SCHEME_V->code; 3785 SCHEME_V->value = SCHEME_V->code;
3743 SCHEME_V->code = car (SCHEME_V->code); 3786 SCHEME_V->code = car (SCHEME_V->code);
3744 s_goto (OP_LET1REC); 3787 s_goto (OP_LET1REC);
3745 3788
3746 case OP_LET1REC: /* letrec (calculate parameters) */ 3789 case OP_LET1REC: /* letrec (calculate parameters) */
3747 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3790 args = cons (SCHEME_V->value, args);
3748 3791
3749 if (is_pair (SCHEME_V->code)) /* continue */ 3792 if (is_pair (SCHEME_V->code)) /* continue */
3750 { 3793 {
3751 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3794 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3752 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); 3795 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3753 3796
3754 s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); 3797 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3755 SCHEME_V->code = cadar (SCHEME_V->code); 3798 SCHEME_V->code = cadar (SCHEME_V->code);
3756 SCHEME_V->args = NIL; 3799 SCHEME_V->args = NIL;
3757 s_goto (OP_EVAL); 3800 s_goto (OP_EVAL);
3758 } 3801 }
3759 else /* end */ 3802 else /* end */
3760 { 3803 {
3761 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3804 args = reverse_in_place (SCHEME_A_ NIL, args);
3762 SCHEME_V->code = car (SCHEME_V->args); 3805 SCHEME_V->code = car (args);
3763 SCHEME_V->args = cdr (SCHEME_V->args); 3806 SCHEME_V->args = cdr (args);
3764 s_goto (OP_LET2REC); 3807 s_goto (OP_LET2REC);
3765 } 3808 }
3766 3809
3767 case OP_LET2REC: /* letrec */ 3810 case OP_LET2REC: /* letrec */
3768 for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) 3811 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3769 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3812 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3770 3813
3771 SCHEME_V->code = cdr (SCHEME_V->code); 3814 SCHEME_V->code = cdr (SCHEME_V->code);
3772 SCHEME_V->args = NIL; 3815 SCHEME_V->args = NIL;
3773 s_goto (OP_BEGIN); 3816 s_goto (OP_BEGIN);
… …
3859 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 3902 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3860 SCHEME_V->code = car (SCHEME_V->code); 3903 SCHEME_V->code = car (SCHEME_V->code);
3861 s_goto (OP_EVAL); 3904 s_goto (OP_EVAL);
3862 3905
3863 case OP_C1STREAM: /* cons-stream */ 3906 case OP_C1STREAM: /* cons-stream */
3864 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */ 3907 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */
3865 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3908 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3866 set_typeflag (x, T_PROMISE); 3909 set_typeflag (x, T_PROMISE);
3867 s_return (cons (SCHEME_V->args, x)); 3910 s_return (cons (args, x));
3868 3911
3869 case OP_MACRO0: /* macro */ 3912 case OP_MACRO0: /* macro */
3870 if (is_pair (car (SCHEME_V->code))) 3913 if (is_pair (car (SCHEME_V->code)))
3871 { 3914 {
3872 x = caar (SCHEME_V->code); 3915 x = caar (SCHEME_V->code);
… …
3905 { 3948 {
3906 if (!is_pair (y = caar (x))) 3949 if (!is_pair (y = caar (x)))
3907 break; 3950 break;
3908 3951
3909 for (; y != NIL; y = cdr (y)) 3952 for (; y != NIL; y = cdr (y))
3910 {
3911 if (eqv (car (y), SCHEME_V->value)) 3953 if (eqv (car (y), SCHEME_V->value))
3912 break; 3954 break;
3913 }
3914 3955
3915 if (y != NIL) 3956 if (y != NIL)
3916 break; 3957 break;
3917 } 3958 }
3918 3959
… …
3938 s_goto (OP_BEGIN); 3979 s_goto (OP_BEGIN);
3939 else 3980 else
3940 s_return (NIL); 3981 s_return (NIL);
3941 3982
3942 case OP_PAPPLY: /* apply */ 3983 case OP_PAPPLY: /* apply */
3943 SCHEME_V->code = car (SCHEME_V->args); 3984 SCHEME_V->code = car (args);
3944 SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); 3985 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3945 /*SCHEME_V->args = cadr(SCHEME_V->args); */ 3986 /*SCHEME_V->args = cadr(args); */
3946 s_goto (OP_APPLY); 3987 s_goto (OP_APPLY);
3947 3988
3948 case OP_PEVAL: /* eval */ 3989 case OP_PEVAL: /* eval */
3949 if (cdr (SCHEME_V->args) != NIL) 3990 if (cdr (args) != NIL)
3950 SCHEME_V->envir = cadr (SCHEME_V->args); 3991 SCHEME_V->envir = cadr (args);
3951 3992
3952 SCHEME_V->code = car (SCHEME_V->args); 3993 SCHEME_V->code = car (args);
3953 s_goto (OP_EVAL); 3994 s_goto (OP_EVAL);
3954 3995
3955 case OP_CONTINUATION: /* call-with-current-continuation */ 3996 case OP_CONTINUATION: /* call-with-current-continuation */
3956 SCHEME_V->code = car (SCHEME_V->args); 3997 SCHEME_V->code = car (args);
3957 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); 3998 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3958 s_goto (OP_APPLY); 3999 s_goto (OP_APPLY);
3959 } 4000 }
3960 4001
3961 return S_T; 4002 if (USE_ERROR_CHECKING) abort ();
3962} 4003}
3963 4004
3964static pointer 4005/* math, cxr */
4006ecb_hot static int
3965opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4007opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3966{ 4008{
3967 pointer x; 4009 pointer args = SCHEME_V->args;
4010 pointer x = car (args);
3968 num v; 4011 num v;
3969 4012
4013 switch (op)
4014 {
3970#if USE_MATH 4015#if USE_MATH
3971 RVALUE dd;
3972#endif
3973
3974 switch (op)
3975 {
3976#if USE_MATH
3977
3978 case OP_INEX2EX: /* inexact->exact */ 4016 case OP_INEX2EX: /* inexact->exact */
3979 x = car (SCHEME_V->args);
3980
3981 if (num_is_integer (x)) 4017 if (!is_integer (x))
3982 s_return (x); 4018 {
3983 else if (modf (rvalue_unchecked (x), &dd) == 0.0) 4019 RVALUE r = rvalue_unchecked (x);
3984 s_return (mk_integer (SCHEME_A_ ivalue (x))); 4020
4021 if (r == (RVALUE)(IVALUE)r)
4022 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
3985 else 4023 else
3986 Error_1 ("inexact->exact: not integral:", x); 4024 Error_1 ("inexact->exact: not integral:", x);
4025 }
3987 4026
3988 case OP_EXP: 4027 s_return (x);
3989 x = car (SCHEME_V->args); 4028
4029 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4030 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4031 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4032 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4033
4034 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3990 s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4035 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3991
3992 case OP_LOG:
3993 x = car (SCHEME_V->args);
3994 s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4036 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
3995 4037 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
3996 case OP_SIN:
3997 x = car (SCHEME_V->args);
3998 s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4038 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3999
4000 case OP_COS:
4001 x = car (SCHEME_V->args);
4002 s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4039 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4003
4004 case OP_TAN:
4005 x = car (SCHEME_V->args);
4006 s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4040 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4007
4008 case OP_ASIN:
4009 x = car (SCHEME_V->args);
4010 s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4041 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4011
4012 case OP_ACOS:
4013 x = car (SCHEME_V->args);
4014 s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4042 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4015 4043
4016 case OP_ATAN: 4044 case OP_ATAN:
4017 x = car (SCHEME_V->args);
4018
4019 if (cdr (SCHEME_V->args) == NIL)
4020 s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
4021 else
4022 {
4023 pointer y = cadr (SCHEME_V->args);
4024
4025 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4026 }
4027
4028 case OP_SQRT:
4029 x = car (SCHEME_V->args);
4030 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); 4045 s_return (mk_real (SCHEME_A_
4046 cdr (args) == NIL
4047 ? atan (rvalue (x))
4048 : atan2 (rvalue (x), rvalue (cadr (args)))));
4031 4049
4032 case OP_EXPT: 4050 case OP_EXPT:
4033 { 4051 {
4034 RVALUE result; 4052 RVALUE result;
4035 int real_result = 1; 4053 int real_result = 1;
4036 pointer y = cadr (SCHEME_V->args); 4054 pointer y = cadr (args);
4037 4055
4038 x = car (SCHEME_V->args);
4039
4040 if (num_is_integer (x) && num_is_integer (y)) 4056 if (is_integer (x) && is_integer (y))
4041 real_result = 0; 4057 real_result = 0;
4042 4058
4043 /* This 'if' is an R5RS compatibility fix. */ 4059 /* This 'if' is an R5RS compatibility fix. */
4044 /* NOTE: Remove this 'if' fix for R6RS. */ 4060 /* NOTE: Remove this 'if' fix for R6RS. */
4045 if (rvalue (x) == 0 && rvalue (y) < 0) 4061 if (rvalue (x) == 0 && rvalue (y) < 0)
4046 result = 0.0; 4062 result = 0;
4047 else 4063 else
4048 result = pow (rvalue (x), rvalue (y)); 4064 result = pow (rvalue (x), rvalue (y));
4049 4065
4050 /* Before returning integer result make sure we can. */ 4066 /* Before returning integer result make sure we can. */
4051 /* If the test fails, result is too big for integer. */ 4067 /* If the test fails, result is too big for integer. */
4052 if (!real_result) 4068 if (!real_result)
4053 { 4069 {
4054 long result_as_long = (long) result; 4070 long result_as_long = result;
4055 4071
4056 if (result != (RVALUE) result_as_long) 4072 if (result != result_as_long)
4057 real_result = 1; 4073 real_result = 1;
4058 } 4074 }
4059 4075
4060 if (real_result) 4076 if (real_result)
4061 s_return (mk_real (SCHEME_A_ result)); 4077 s_return (mk_real (SCHEME_A_ result));
4062 else 4078 else
4063 s_return (mk_integer (SCHEME_A_ result)); 4079 s_return (mk_integer (SCHEME_A_ result));
4064 } 4080 }
4065
4066 case OP_FLOOR:
4067 x = car (SCHEME_V->args);
4068 s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4069
4070 case OP_CEILING:
4071 x = car (SCHEME_V->args);
4072 s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4073
4074 case OP_TRUNCATE:
4075 {
4076 RVALUE rvalue_of_x;
4077
4078 x = car (SCHEME_V->args);
4079 rvalue_of_x = rvalue (x);
4080
4081 if (rvalue_of_x > 0)
4082 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4083 else
4084 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4085 }
4086
4087 case OP_ROUND:
4088 x = car (SCHEME_V->args);
4089
4090 if (num_is_integer (x))
4091 s_return (x);
4092
4093 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4094#endif 4081#endif
4095 4082
4096 case OP_ADD: /* + */ 4083 case OP_ADD: /* + */
4097 v = num_zero; 4084 v = num_zero;
4098 4085
4099 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4086 for (x = args; x != NIL; x = cdr (x))
4100 v = num_add (v, nvalue (car (x))); 4087 v = num_op (NUM_ADD, v, nvalue (car (x)));
4101 4088
4102 s_return (mk_number (SCHEME_A_ v)); 4089 s_return (mk_number (SCHEME_A_ v));
4103 4090
4104 case OP_MUL: /* * */ 4091 case OP_MUL: /* * */
4105 v = num_one; 4092 v = num_one;
4106 4093
4107 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4094 for (x = args; x != NIL; x = cdr (x))
4108 v = num_mul (v, nvalue (car (x))); 4095 v = num_op (NUM_MUL, v, nvalue (car (x)));
4109 4096
4110 s_return (mk_number (SCHEME_A_ v)); 4097 s_return (mk_number (SCHEME_A_ v));
4111 4098
4112 case OP_SUB: /* - */ 4099 case OP_SUB: /* - */
4113 if (cdr (SCHEME_V->args) == NIL) 4100 if (cdr (args) == NIL)
4114 { 4101 {
4115 x = SCHEME_V->args; 4102 x = args;
4116 v = num_zero; 4103 v = num_zero;
4117 } 4104 }
4118 else 4105 else
4119 { 4106 {
4120 x = cdr (SCHEME_V->args); 4107 x = cdr (args);
4121 v = nvalue (car (SCHEME_V->args)); 4108 v = nvalue (car (args));
4122 } 4109 }
4123 4110
4124 for (; x != NIL; x = cdr (x)) 4111 for (; x != NIL; x = cdr (x))
4125 v = num_sub (v, nvalue (car (x))); 4112 v = num_op (NUM_SUB, v, nvalue (car (x)));
4126 4113
4127 s_return (mk_number (SCHEME_A_ v)); 4114 s_return (mk_number (SCHEME_A_ v));
4128 4115
4129 case OP_DIV: /* / */ 4116 case OP_DIV: /* / */
4130 if (cdr (SCHEME_V->args) == NIL) 4117 if (cdr (args) == NIL)
4131 { 4118 {
4132 x = SCHEME_V->args; 4119 x = args;
4133 v = num_one; 4120 v = num_one;
4134 } 4121 }
4135 else 4122 else
4136 { 4123 {
4137 x = cdr (SCHEME_V->args); 4124 x = cdr (args);
4138 v = nvalue (car (SCHEME_V->args)); 4125 v = nvalue (car (args));
4139 } 4126 }
4140 4127
4141 for (; x != NIL; x = cdr (x)) 4128 for (; x != NIL; x = cdr (x))
4142 {
4143 if (!is_zero_rvalue (rvalue (car (x)))) 4129 if (!is_zero_rvalue (rvalue (car (x))))
4144 v = num_div (v, nvalue (car (x))); 4130 v = num_div (v, nvalue (car (x)));
4145 else 4131 else
4146 Error_0 ("/: division by zero"); 4132 Error_0 ("/: division by zero");
4147 }
4148 4133
4149 s_return (mk_number (SCHEME_A_ v)); 4134 s_return (mk_number (SCHEME_A_ v));
4150 4135
4151 case OP_INTDIV: /* quotient */ 4136 case OP_INTDIV: /* quotient */
4152 if (cdr (SCHEME_V->args) == NIL) 4137 if (cdr (args) == NIL)
4153 { 4138 {
4154 x = SCHEME_V->args; 4139 x = args;
4155 v = num_one; 4140 v = num_one;
4156 } 4141 }
4157 else 4142 else
4158 { 4143 {
4159 x = cdr (SCHEME_V->args); 4144 x = cdr (args);
4160 v = nvalue (car (SCHEME_V->args)); 4145 v = nvalue (car (args));
4161 } 4146 }
4162 4147
4163 for (; x != NIL; x = cdr (x)) 4148 for (; x != NIL; x = cdr (x))
4164 { 4149 {
4165 if (ivalue (car (x)) != 0) 4150 if (ivalue (car (x)) != 0)
4166 v = num_intdiv (v, nvalue (car (x))); 4151 v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4167 else 4152 else
4168 Error_0 ("quotient: division by zero"); 4153 Error_0 ("quotient: division by zero");
4169 } 4154 }
4170 4155
4171 s_return (mk_number (SCHEME_A_ v)); 4156 s_return (mk_number (SCHEME_A_ v));
4172 4157
4173 case OP_REM: /* remainder */ 4158 case OP_REM: /* remainder */
4174 v = nvalue (car (SCHEME_V->args)); 4159 v = nvalue (x);
4175 4160
4176 if (ivalue (cadr (SCHEME_V->args)) != 0) 4161 if (ivalue (cadr (args)) != 0)
4177 v = num_rem (v, nvalue (cadr (SCHEME_V->args))); 4162 v = num_rem (v, nvalue (cadr (args)));
4178 else 4163 else
4179 Error_0 ("remainder: division by zero"); 4164 Error_0 ("remainder: division by zero");
4180 4165
4181 s_return (mk_number (SCHEME_A_ v)); 4166 s_return (mk_number (SCHEME_A_ v));
4182 4167
4183 case OP_MOD: /* modulo */ 4168 case OP_MOD: /* modulo */
4184 v = nvalue (car (SCHEME_V->args)); 4169 v = nvalue (x);
4185 4170
4186 if (ivalue (cadr (SCHEME_V->args)) != 0) 4171 if (ivalue (cadr (args)) != 0)
4187 v = num_mod (v, nvalue (cadr (SCHEME_V->args))); 4172 v = num_mod (v, nvalue (cadr (args)));
4188 else 4173 else
4189 Error_0 ("modulo: division by zero"); 4174 Error_0 ("modulo: division by zero");
4190 4175
4191 s_return (mk_number (SCHEME_A_ v)); 4176 s_return (mk_number (SCHEME_A_ v));
4192 4177
4193 case OP_CAR: /* car */ 4178 /* the compiler will optimize this mess... */
4194 s_return (caar (SCHEME_V->args)); 4179 case OP_CAR: op_car: s_return (car (x));
4195 4180 case OP_CDR: op_cdr: s_return (cdr (x));
4196 case OP_CDR: /* cdr */ 4181 case OP_CAAR: op_caar: x = car (x); goto op_car;
4197 s_return (cdar (SCHEME_V->args)); 4182 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4183 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4184 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4185 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4186 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4187 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4188 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4189 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4190 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4191 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4192 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4193 case OP_CAAAAR: x = car (x); goto op_caaar;
4194 case OP_CAAADR: x = cdr (x); goto op_caaar;
4195 case OP_CAADAR: x = car (x); goto op_caadr;
4196 case OP_CAADDR: x = cdr (x); goto op_caadr;
4197 case OP_CADAAR: x = car (x); goto op_cadar;
4198 case OP_CADADR: x = cdr (x); goto op_cadar;
4199 case OP_CADDAR: x = car (x); goto op_caddr;
4200 case OP_CADDDR: x = cdr (x); goto op_caddr;
4201 case OP_CDAAAR: x = car (x); goto op_cdaar;
4202 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4203 case OP_CDADAR: x = car (x); goto op_cdadr;
4204 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4205 case OP_CDDAAR: x = car (x); goto op_cddar;
4206 case OP_CDDADR: x = cdr (x); goto op_cddar;
4207 case OP_CDDDAR: x = car (x); goto op_cdddr;
4208 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4198 4209
4199 case OP_CONS: /* cons */ 4210 case OP_CONS: /* cons */
4200 set_cdr (SCHEME_V->args, cadr (SCHEME_V->args)); 4211 set_cdr (args, cadr (args));
4201 s_return (SCHEME_V->args); 4212 s_return (args);
4202 4213
4203 case OP_SETCAR: /* set-car! */ 4214 case OP_SETCAR: /* set-car! */
4204 if (!is_immutable (car (SCHEME_V->args))) 4215 if (!is_immutable (x))
4205 { 4216 {
4206 set_car (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4217 set_car (x, cadr (args));
4207 s_return (car (SCHEME_V->args)); 4218 s_return (car (args));
4208 } 4219 }
4209 else 4220 else
4210 Error_0 ("set-car!: unable to alter immutable pair"); 4221 Error_0 ("set-car!: unable to alter immutable pair");
4211 4222
4212 case OP_SETCDR: /* set-cdr! */ 4223 case OP_SETCDR: /* set-cdr! */
4213 if (!is_immutable (car (SCHEME_V->args))) 4224 if (!is_immutable (x))
4214 { 4225 {
4215 set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4226 set_cdr (x, cadr (args));
4216 s_return (car (SCHEME_V->args)); 4227 s_return (car (args));
4217 } 4228 }
4218 else 4229 else
4219 Error_0 ("set-cdr!: unable to alter immutable pair"); 4230 Error_0 ("set-cdr!: unable to alter immutable pair");
4220 4231
4221 case OP_CHAR2INT: /* char->integer */ 4232 case OP_CHAR2INT: /* char->integer */
4222 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4233 s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4223 4234
4224 case OP_INT2CHAR: /* integer->char */ 4235 case OP_INT2CHAR: /* integer->char */
4225 s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4236 s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4226 4237
4227 case OP_CHARUPCASE: 4238 case OP_CHARUPCASE:
4228 { 4239 {
4229 unsigned char c = ivalue (car (SCHEME_V->args)); 4240 unsigned char c = ivalue_unchecked (x);
4230 c = toupper (c); 4241 c = toupper (c);
4231 s_return (mk_character (SCHEME_A_ c)); 4242 s_return (mk_character (SCHEME_A_ c));
4232 } 4243 }
4233 4244
4234 case OP_CHARDNCASE: 4245 case OP_CHARDNCASE:
4235 { 4246 {
4236 unsigned char c = ivalue (car (SCHEME_V->args)); 4247 unsigned char c = ivalue_unchecked (x);
4237 c = tolower (c); 4248 c = tolower (c);
4238 s_return (mk_character (SCHEME_A_ c)); 4249 s_return (mk_character (SCHEME_A_ c));
4239 } 4250 }
4240 4251
4241 case OP_STR2SYM: /* string->symbol */ 4252 case OP_STR2SYM: /* string->symbol */
4242 s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); 4253 s_return (mk_symbol (SCHEME_A_ strvalue (x)));
4243 4254
4244 case OP_STR2ATOM: /* string->atom */ 4255 case OP_STR2ATOM: /* string->atom */
4245 { 4256 {
4246 char *s = strvalue (car (SCHEME_V->args)); 4257 char *s = strvalue (x);
4247 long pf = 0; 4258 long pf = 0;
4248 4259
4249 if (cdr (SCHEME_V->args) != NIL) 4260 if (cdr (args) != NIL)
4250 { 4261 {
4251 /* we know cadr(SCHEME_V->args) is a natural number */ 4262 /* we know cadr(args) is a natural number */
4252 /* see if it is 2, 8, 10, or 16, or error */ 4263 /* see if it is 2, 8, 10, or 16, or error */
4253 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4264 pf = ivalue_unchecked (cadr (args));
4254 4265
4255 if (pf == 16 || pf == 10 || pf == 8 || pf == 2) 4266 if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4256 { 4267 {
4257 /* base is OK */ 4268 /* base is OK */
4258 } 4269 }
4259 else 4270 else
4260 pf = -1; 4271 pf = -1;
4261 } 4272 }
4262 4273
4263 if (pf < 0) 4274 if (pf < 0)
4264 Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); 4275 Error_1 ("string->atom: bad base:", cadr (args));
4265 else if (*s == '#') /* no use of base! */ 4276 else if (*s == '#') /* no use of base! */
4266 s_return (mk_sharp_const (SCHEME_A_ s + 1)); 4277 s_return (mk_sharp_const (SCHEME_A_ s + 1));
4267 else 4278 else
4268 { 4279 {
4269 if (pf == 0 || pf == 10) 4280 if (pf == 0 || pf == 10)
… …
4280 } 4291 }
4281 } 4292 }
4282 } 4293 }
4283 4294
4284 case OP_SYM2STR: /* symbol->string */ 4295 case OP_SYM2STR: /* symbol->string */
4285 x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args))); 4296 x = mk_string (SCHEME_A_ symname (x));
4286 setimmutable (x); 4297 setimmutable (x);
4287 s_return (x); 4298 s_return (x);
4288 4299
4289 case OP_ATOM2STR: /* atom->string */ 4300 case OP_ATOM2STR: /* atom->string */
4290 { 4301 {
4291 long pf = 0; 4302 long pf = 0;
4292 4303
4293 x = car (SCHEME_V->args);
4294
4295 if (cdr (SCHEME_V->args) != NIL) 4304 if (cdr (args) != NIL)
4296 { 4305 {
4297 /* we know cadr(SCHEME_V->args) is a natural number */ 4306 /* we know cadr(args) is a natural number */
4298 /* see if it is 2, 8, 10, or 16, or error */ 4307 /* see if it is 2, 8, 10, or 16, or error */
4299 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4308 pf = ivalue_unchecked (cadr (args));
4300 4309
4301 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) 4310 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4302 { 4311 {
4303 /* base is OK */ 4312 /* base is OK */
4304 } 4313 }
4305 else 4314 else
4306 pf = -1; 4315 pf = -1;
4307 } 4316 }
4308 4317
4309 if (pf < 0) 4318 if (pf < 0)
4310 Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); 4319 Error_1 ("atom->string: bad base:", cadr (args));
4311 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) 4320 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4312 { 4321 {
4313 char *p; 4322 char *p;
4314 int len; 4323 int len;
4315 4324
… …
4320 Error_1 ("atom->string: not an atom:", x); 4329 Error_1 ("atom->string: not an atom:", x);
4321 } 4330 }
4322 4331
4323 case OP_MKSTRING: /* make-string */ 4332 case OP_MKSTRING: /* make-string */
4324 { 4333 {
4325 int fill = ' '; 4334 int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4326 int len; 4335 int len = ivalue_unchecked (x);
4327 4336
4328 len = ivalue (car (SCHEME_V->args));
4329
4330 if (cdr (SCHEME_V->args) != NIL)
4331 fill = charvalue (cadr (SCHEME_V->args));
4332
4333 s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); 4337 s_return (mk_empty_string (SCHEME_A_ len, fill));
4334 } 4338 }
4335 4339
4336 case OP_STRLEN: /* string-length */ 4340 case OP_STRLEN: /* string-length */
4337 s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args)))); 4341 s_return (mk_integer (SCHEME_A_ strlength (x)));
4338 4342
4339 case OP_STRREF: /* string-ref */ 4343 case OP_STRREF: /* string-ref */
4340 { 4344 {
4341 char *str; 4345 char *str = strvalue (x);
4342 int index;
4343
4344 str = strvalue (car (SCHEME_V->args));
4345
4346 index = ivalue (cadr (SCHEME_V->args)); 4346 int index = ivalue_unchecked (cadr (args));
4347 4347
4348 if (index >= strlength (car (SCHEME_V->args))) 4348 if (index >= strlength (x))
4349 Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); 4349 Error_1 ("string-ref: out of bounds:", cadr (args));
4350 4350
4351 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); 4351 s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4352 } 4352 }
4353 4353
4354 case OP_STRSET: /* string-set! */ 4354 case OP_STRSET: /* string-set! */
4355 { 4355 {
4356 char *str; 4356 char *str = strvalue (x);
4357 int index; 4357 int index = ivalue_unchecked (cadr (args));
4358 int c; 4358 int c;
4359 4359
4360 if (is_immutable (car (SCHEME_V->args))) 4360 if (is_immutable (x))
4361 Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); 4361 Error_1 ("string-set!: unable to alter immutable string:", x);
4362 4362
4363 str = strvalue (car (SCHEME_V->args));
4364
4365 index = ivalue (cadr (SCHEME_V->args));
4366
4367 if (index >= strlength (car (SCHEME_V->args))) 4363 if (index >= strlength (x))
4368 Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); 4364 Error_1 ("string-set!: out of bounds:", cadr (args));
4369 4365
4370 c = charvalue (caddr (SCHEME_V->args)); 4366 c = charvalue (caddr (args));
4371 4367
4372 str[index] = (char) c; 4368 str[index] = c;
4373 s_return (car (SCHEME_V->args)); 4369 s_return (car (args));
4374 } 4370 }
4375 4371
4376 case OP_STRAPPEND: /* string-append */ 4372 case OP_STRAPPEND: /* string-append */
4377 { 4373 {
4378 /* in 1.29 string-append was in Scheme in init.scm but was too slow */ 4374 /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4379 int len = 0; 4375 int len = 0;
4380 pointer newstr; 4376 pointer newstr;
4381 char *pos; 4377 char *pos;
4382 4378
4383 /* compute needed length for new string */ 4379 /* compute needed length for new string */
4384 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4380 for (x = args; x != NIL; x = cdr (x))
4385 len += strlength (car (x)); 4381 len += strlength (car (x));
4386 4382
4387 newstr = mk_empty_string (SCHEME_A_ len, ' '); 4383 newstr = mk_empty_string (SCHEME_A_ len, ' ');
4388 4384
4389 /* store the contents of the argument strings into the new string */ 4385 /* store the contents of the argument strings into the new string */
4390 for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) 4386 for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4391 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4387 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4392 4388
4393 s_return (newstr); 4389 s_return (newstr);
4394 } 4390 }
4395 4391
4396 case OP_SUBSTR: /* substring */ 4392 case OP_STRING_COPY: /* substring/string-copy */
4397 { 4393 {
4398 char *str; 4394 char *str = strvalue (x);
4399 int index0; 4395 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4400 int index1; 4396 int index1;
4401 int len; 4397 int len;
4402 4398
4403 str = strvalue (car (SCHEME_V->args));
4404
4405 index0 = ivalue (cadr (SCHEME_V->args));
4406
4407 if (index0 > strlength (car (SCHEME_V->args))) 4399 if (index0 > strlength (x))
4408 Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); 4400 Error_1 ("string->copy: start out of bounds:", cadr (args));
4409 4401
4410 if (cddr (SCHEME_V->args) != NIL) 4402 if (cddr (args) != NIL)
4411 { 4403 {
4412 index1 = ivalue (caddr (SCHEME_V->args)); 4404 index1 = ivalue_unchecked (caddr (args));
4413 4405
4414 if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) 4406 if (index1 > strlength (x) || index1 < index0)
4415 Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); 4407 Error_1 ("string->copy: end out of bounds:", caddr (args));
4416 } 4408 }
4417 else 4409 else
4418 index1 = strlength (car (SCHEME_V->args)); 4410 index1 = strlength (x);
4419 4411
4420 len = index1 - index0; 4412 len = index1 - index0;
4421 x = mk_empty_string (SCHEME_A_ len, ' '); 4413 x = mk_counted_string (SCHEME_A_ str + index0, len);
4422 memcpy (strvalue (x), str + index0, len);
4423 strvalue (x)[len] = 0;
4424 4414
4425 s_return (x); 4415 s_return (x);
4426 } 4416 }
4427 4417
4428 case OP_VECTOR: /* vector */ 4418 case OP_VECTOR: /* vector */
4429 { 4419 {
4430 int i; 4420 int i;
4431 pointer vec; 4421 pointer vec;
4432 int len = list_length (SCHEME_A_ SCHEME_V->args); 4422 int len = list_length (SCHEME_A_ args);
4433 4423
4434 if (len < 0) 4424 if (len < 0)
4435 Error_1 ("vector: not a proper list:", SCHEME_V->args); 4425 Error_1 ("vector: not a proper list:", args);
4436 4426
4437 vec = mk_vector (SCHEME_A_ len); 4427 vec = mk_vector (SCHEME_A_ len);
4438 4428
4439#if USE_ERROR_CHECKING 4429#if USE_ERROR_CHECKING
4440 if (SCHEME_V->no_memory) 4430 if (SCHEME_V->no_memory)
4441 s_return (S_SINK); 4431 s_return (S_SINK);
4442#endif 4432#endif
4443 4433
4444 for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++) 4434 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4445 set_vector_elem (vec, i, car (x)); 4435 vector_set (vec, i, car (x));
4446 4436
4447 s_return (vec); 4437 s_return (vec);
4448 } 4438 }
4449 4439
4450 case OP_MKVECTOR: /* make-vector */ 4440 case OP_MKVECTOR: /* make-vector */
4451 { 4441 {
4452 pointer fill = NIL; 4442 pointer fill = NIL;
4453 int len;
4454 pointer vec; 4443 pointer vec;
4444 int len = ivalue_unchecked (x);
4455 4445
4456 len = ivalue (car (SCHEME_V->args));
4457
4458 if (cdr (SCHEME_V->args) != NIL) 4446 if (cdr (args) != NIL)
4459 fill = cadr (SCHEME_V->args); 4447 fill = cadr (args);
4460 4448
4461 vec = mk_vector (SCHEME_A_ len); 4449 vec = mk_vector (SCHEME_A_ len);
4462 4450
4463#if USE_ERROR_CHECKING 4451#if USE_ERROR_CHECKING
4464 if (SCHEME_V->no_memory) 4452 if (SCHEME_V->no_memory)
4465 s_return (S_SINK); 4453 s_return (S_SINK);
4466#endif 4454#endif
4467 4455
4468 if (fill != NIL) 4456 if (fill != NIL)
4469 fill_vector (vec, fill); 4457 fill_vector (vec, 0, fill);
4470 4458
4471 s_return (vec); 4459 s_return (vec);
4472 } 4460 }
4473 4461
4474 case OP_VECLEN: /* vector-length */ 4462 case OP_VECLEN: /* vector-length */
4475 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args)))); 4463 s_return (mk_integer (SCHEME_A_ veclength (x)));
4464
4465 case OP_VECRESIZE:
4466 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4467 s_return (x);
4476 4468
4477 case OP_VECREF: /* vector-ref */ 4469 case OP_VECREF: /* vector-ref */
4478 { 4470 {
4479 int index;
4480
4481 index = ivalue (cadr (SCHEME_V->args)); 4471 int index = ivalue_unchecked (cadr (args));
4482 4472
4483 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4473 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4484 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4474 Error_1 ("vector-ref: out of bounds:", cadr (args));
4485 4475
4486 s_return (vector_elem (car (SCHEME_V->args), index)); 4476 s_return (vector_get (x, index));
4487 } 4477 }
4488 4478
4489 case OP_VECSET: /* vector-set! */ 4479 case OP_VECSET: /* vector-set! */
4490 { 4480 {
4491 int index; 4481 int index = ivalue_unchecked (cadr (args));
4492 4482
4493 if (is_immutable (car (SCHEME_V->args))) 4483 if (is_immutable (x))
4494 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4484 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4495 4485
4496 index = ivalue (cadr (SCHEME_V->args));
4497
4498 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4486 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4499 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4487 Error_1 ("vector-set!: out of bounds:", cadr (args));
4500 4488
4501 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4489 vector_set (x, index, caddr (args));
4502 s_return (car (SCHEME_V->args)); 4490 s_return (x);
4503 } 4491 }
4504 } 4492 }
4505 4493
4506 return S_T; 4494 if (USE_ERROR_CHECKING) abort ();
4507} 4495}
4508 4496
4509INTERFACE int 4497/* relational ops */
4510is_list (SCHEME_P_ pointer a) 4498ecb_hot static int
4499opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4511{ 4500{
4512 return list_length (SCHEME_A_ a) >= 0; 4501 pointer x = SCHEME_V->args;
4513}
4514 4502
4515/* Result is: 4503 for (;;)
4516 proper list: length
4517 circular list: -1
4518 not even a pair: -2
4519 dotted list: -2 minus length before dot
4520*/
4521INTERFACE int
4522list_length (SCHEME_P_ pointer a)
4523{
4524 int i = 0;
4525 pointer slow, fast;
4526
4527 slow = fast = a;
4528
4529 while (1)
4530 { 4504 {
4505 num v = nvalue (car (x));
4506 x = cdr (x);
4507
4531 if (fast == NIL) 4508 if (x == NIL)
4532 return i; 4509 break;
4533 4510
4534 if (!is_pair (fast)) 4511 int r = num_cmp (v, nvalue (car (x)));
4535 return -2 - i;
4536 4512
4537 fast = cdr (fast); 4513 switch (op)
4538 ++i;
4539
4540 if (fast == NIL)
4541 return i;
4542
4543 if (!is_pair (fast))
4544 return -2 - i;
4545
4546 ++i;
4547 fast = cdr (fast);
4548
4549 /* Safe because we would have already returned if `fast'
4550 encountered a non-pair. */
4551 slow = cdr (slow);
4552
4553 if (fast == slow)
4554 { 4514 {
4555 /* the fast pointer has looped back around and caught up 4515 case OP_NUMEQ: r = r == 0; break;
4556 with the slow pointer, hence the structure is circular, 4516 case OP_LESS: r = r < 0; break;
4557 not of finite length, and therefore not a list */ 4517 case OP_GRE: r = r > 0; break;
4558 return -1; 4518 case OP_LEQ: r = r <= 0; break;
4519 case OP_GEQ: r = r >= 0; break;
4559 } 4520 }
4560 }
4561}
4562 4521
4563static pointer 4522 if (!r)
4523 s_return (S_F);
4524 }
4525
4526 s_return (S_T);
4527}
4528
4529/* predicates */
4530ecb_hot static int
4564opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4531opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4565{ 4532{
4566 pointer x; 4533 pointer args = SCHEME_V->args;
4567 num v; 4534 pointer a = car (args);
4568 int (*comp_func) (num, num); 4535 pointer d = cdr (args);
4536 int r;
4569 4537
4570 switch (op) 4538 switch (op)
4571 { 4539 {
4572 case OP_NOT: /* not */ 4540 case OP_NOT: /* not */ r = is_false (a) ; break;
4573 s_retbool (is_false (car (SCHEME_V->args))); 4541 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4542 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4543 case OP_NULLP: /* null? */ r = a == NIL ; break;
4544 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4545 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4546 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4547 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4548 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4549 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4550 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4574 4551
4575 case OP_BOOLP: /* boolean? */
4576 s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T);
4577
4578 case OP_EOFOBJP: /* boolean? */
4579 s_retbool (car (SCHEME_V->args) == S_EOF);
4580
4581 case OP_NULLP: /* null? */
4582 s_retbool (car (SCHEME_V->args) == NIL);
4583
4584 case OP_NUMEQ: /* = */
4585 case OP_LESS: /* < */
4586 case OP_GRE: /* > */
4587 case OP_LEQ: /* <= */
4588 case OP_GEQ: /* >= */
4589 switch (op)
4590 {
4591 case OP_NUMEQ:
4592 comp_func = num_eq;
4593 break;
4594
4595 case OP_LESS:
4596 comp_func = num_lt;
4597 break;
4598
4599 case OP_GRE:
4600 comp_func = num_gt;
4601 break;
4602
4603 case OP_LEQ:
4604 comp_func = num_le;
4605 break;
4606
4607 case OP_GEQ:
4608 comp_func = num_ge;
4609 break;
4610 }
4611
4612 x = SCHEME_V->args;
4613 v = nvalue (car (x));
4614 x = cdr (x);
4615
4616 for (; x != NIL; x = cdr (x))
4617 {
4618 if (!comp_func (v, nvalue (car (x))))
4619 s_retbool (0);
4620
4621 v = nvalue (car (x));
4622 }
4623
4624 s_retbool (1);
4625
4626 case OP_SYMBOLP: /* symbol? */
4627 s_retbool (is_symbol (car (SCHEME_V->args)));
4628
4629 case OP_NUMBERP: /* number? */
4630 s_retbool (is_number (car (SCHEME_V->args)));
4631
4632 case OP_STRINGP: /* string? */
4633 s_retbool (is_string (car (SCHEME_V->args)));
4634
4635 case OP_INTEGERP: /* integer? */
4636 s_retbool (is_integer (car (SCHEME_V->args)));
4637
4638 case OP_REALP: /* real? */
4639 s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */
4640
4641 case OP_CHARP: /* char? */
4642 s_retbool (is_character (car (SCHEME_V->args)));
4643#if USE_CHAR_CLASSIFIERS 4552#if USE_CHAR_CLASSIFIERS
4644 4553 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4645 case OP_CHARAP: /* char-alphabetic? */ 4554 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4646 s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); 4555 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4647 4556 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4648 case OP_CHARNP: /* char-numeric? */ 4557 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4649 s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));
4650
4651 case OP_CHARWP: /* char-whitespace? */
4652 s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));
4653
4654 case OP_CHARUP: /* char-upper-case? */
4655 s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));
4656
4657 case OP_CHARLP: /* char-lower-case? */
4658 s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
4659#endif 4558#endif
4559
4660#if USE_PORTS 4560#if USE_PORTS
4661 4561 case OP_PORTP: /* port? */ r = is_port (a) ; break;
4662 case OP_PORTP: /* port? */
4663 s_retbool (is_port (car (SCHEME_V->args)));
4664
4665 case OP_INPORTP: /* input-port? */ 4562 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4666 s_retbool (is_inport (car (SCHEME_V->args)));
4667
4668 case OP_OUTPORTP: /* output-port? */ 4563 case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4669 s_retbool (is_outport (car (SCHEME_V->args)));
4670#endif 4564#endif
4671 4565
4672 case OP_PROCP: /* procedure? */ 4566 case OP_PROCP: /* procedure? */
4673 4567
4674 /*-- 4568 /*--
4675 * continuation should be procedure by the example 4569 * continuation should be procedure by the example
4676 * (call-with-current-continuation procedure?) ==> #t 4570 * (call-with-current-continuation procedure?) ==> #t
4677 * in R^3 report sec. 6.9 4571 * in R^3 report sec. 6.9
4678 */ 4572 */
4679 s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) 4573 r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4680 || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); 4574 break;
4681 4575
4682 case OP_PAIRP: /* pair? */ 4576 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4683 s_retbool (is_pair (car (SCHEME_V->args))); 4577 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4684 4578 case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4685 case OP_LISTP: /* list? */ 4579 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4686 s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); 4580 case OP_EQ: /* eq? */ r = a == cadr (args) ; break;
4687 4581 case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break;
4688 case OP_ENVP: /* environment? */
4689 s_retbool (is_environment (car (SCHEME_V->args)));
4690
4691 case OP_VECTORP: /* vector? */
4692 s_retbool (is_vector (car (SCHEME_V->args)));
4693
4694 case OP_EQ: /* eq? */
4695 s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));
4696
4697 case OP_EQV: /* eqv? */
4698 s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
4699 } 4582 }
4700 4583
4701 return S_T; 4584 s_retbool (r);
4702} 4585}
4703 4586
4704static pointer 4587/* promises, list ops, ports */
4588ecb_hot static int
4705opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4589opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4706{ 4590{
4591 pointer args = SCHEME_V->args;
4592 pointer a = car (args);
4707 pointer x, y; 4593 pointer x, y;
4708 4594
4709 switch (op) 4595 switch (op)
4710 { 4596 {
4711 case OP_FORCE: /* force */ 4597 case OP_FORCE: /* force */
4712 SCHEME_V->code = car (SCHEME_V->args); 4598 SCHEME_V->code = a;
4713 4599
4714 if (is_promise (SCHEME_V->code)) 4600 if (is_promise (SCHEME_V->code))
4715 { 4601 {
4716 /* Should change type to closure here */ 4602 /* Should change type to closure here */
4717 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code); 4603 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
… …
4720 } 4606 }
4721 else 4607 else
4722 s_return (SCHEME_V->code); 4608 s_return (SCHEME_V->code);
4723 4609
4724 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4610 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4725 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4611 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4726 s_return (SCHEME_V->value); 4612 s_return (SCHEME_V->value);
4727 4613
4728#if USE_PORTS 4614#if USE_PORTS
4615
4616 case OP_EOF_OBJECT: /* eof-object */
4617 s_return (S_EOF);
4729 4618
4730 case OP_WRITE: /* write */ 4619 case OP_WRITE: /* write */
4731 case OP_DISPLAY: /* display */ 4620 case OP_DISPLAY: /* display */
4732 case OP_WRITE_CHAR: /* write-char */ 4621 case OP_WRITE_CHAR: /* write-char */
4733 if (is_pair (cdr (SCHEME_V->args))) 4622 if (is_pair (cdr (SCHEME_V->args)))
… …
4738 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4627 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4739 SCHEME_V->outport = cadr (SCHEME_V->args); 4628 SCHEME_V->outport = cadr (SCHEME_V->args);
4740 } 4629 }
4741 } 4630 }
4742 4631
4743 SCHEME_V->args = car (SCHEME_V->args); 4632 SCHEME_V->args = a;
4744 4633
4745 if (op == OP_WRITE) 4634 if (op == OP_WRITE)
4746 SCHEME_V->print_flag = 1; 4635 SCHEME_V->print_flag = 1;
4747 else 4636 else
4748 SCHEME_V->print_flag = 0; 4637 SCHEME_V->print_flag = 0;
4749 4638
4750 s_goto (OP_P0LIST); 4639 s_goto (OP_P0LIST);
4751 4640
4752 case OP_NEWLINE: /* newline */ 4641 case OP_NEWLINE: /* newline */
4753 if (is_pair (SCHEME_V->args)) 4642 if (is_pair (args))
4754 { 4643 {
4755 if (car (SCHEME_V->args) != SCHEME_V->outport) 4644 if (a != SCHEME_V->outport)
4756 { 4645 {
4757 x = cons (SCHEME_V->outport, NIL); 4646 x = cons (SCHEME_V->outport, NIL);
4758 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4647 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4759 SCHEME_V->outport = car (SCHEME_V->args); 4648 SCHEME_V->outport = a;
4760 } 4649 }
4761 } 4650 }
4762 4651
4763 putstr (SCHEME_A_ "\n"); 4652 putstr (SCHEME_A_ "\n");
4764 s_return (S_T); 4653 s_return (S_T);
4765#endif 4654#endif
4766 4655
4767 case OP_ERR0: /* error */ 4656 case OP_ERR0: /* error */
4768 SCHEME_V->retcode = -1; 4657 SCHEME_V->retcode = -1;
4769 4658
4770 if (!is_string (car (SCHEME_V->args))) 4659 if (!is_string (a))
4771 { 4660 {
4772 SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args); 4661 args = cons (mk_string (SCHEME_A_ " -- "), args);
4773 setimmutable (car (SCHEME_V->args)); 4662 setimmutable (car (args));
4774 } 4663 }
4775 4664
4776 putstr (SCHEME_A_ "Error: "); 4665 putstr (SCHEME_A_ "Error: ");
4777 putstr (SCHEME_A_ strvalue (car (SCHEME_V->args))); 4666 putstr (SCHEME_A_ strvalue (car (args)));
4778 SCHEME_V->args = cdr (SCHEME_V->args); 4667 SCHEME_V->args = cdr (args);
4779 s_goto (OP_ERR1); 4668 s_goto (OP_ERR1);
4780 4669
4781 case OP_ERR1: /* error */ 4670 case OP_ERR1: /* error */
4782 putstr (SCHEME_A_ " "); 4671 putstr (SCHEME_A_ " ");
4783 4672
4784 if (SCHEME_V->args != NIL) 4673 if (args != NIL)
4785 { 4674 {
4786 s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL); 4675 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4787 SCHEME_V->args = car (SCHEME_V->args); 4676 SCHEME_V->args = a;
4788 SCHEME_V->print_flag = 1; 4677 SCHEME_V->print_flag = 1;
4789 s_goto (OP_P0LIST); 4678 s_goto (OP_P0LIST);
4790 } 4679 }
4791 else 4680 else
4792 { 4681 {
4793 putstr (SCHEME_A_ "\n"); 4682 putstr (SCHEME_A_ "\n");
4794 4683
4795 if (SCHEME_V->interactive_repl) 4684 if (SCHEME_V->interactive_repl)
4796 s_goto (OP_T0LVL); 4685 s_goto (OP_T0LVL);
4797 else 4686 else
4798 return NIL; 4687 return -1;
4799 } 4688 }
4800 4689
4801 case OP_REVERSE: /* reverse */ 4690 case OP_REVERSE: /* reverse */
4802 s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); 4691 s_return (reverse (SCHEME_A_ a));
4803 4692
4804 case OP_LIST_STAR: /* list* */ 4693 case OP_LIST_STAR: /* list* */
4805 s_return (list_star (SCHEME_A_ SCHEME_V->args)); 4694 s_return (list_star (SCHEME_A_ SCHEME_V->args));
4806 4695
4807 case OP_APPEND: /* append */ 4696 case OP_APPEND: /* append */
4808 x = NIL; 4697 x = NIL;
4809 y = SCHEME_V->args; 4698 y = args;
4810 4699
4811 if (y == x) 4700 if (y == x)
4812 s_return (x); 4701 s_return (x);
4813 4702
4814 /* cdr() in the while condition is not a typo. If car() */ 4703 /* cdr() in the while condition is not a typo. If car() */
… …
4825 s_return (reverse_in_place (SCHEME_A_ car (y), x)); 4714 s_return (reverse_in_place (SCHEME_A_ car (y), x));
4826 4715
4827#if USE_PLIST 4716#if USE_PLIST
4828 4717
4829 case OP_PUT: /* put */ 4718 case OP_PUT: /* put */
4830 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4719 if (!hasprop (a) || !hasprop (cadr (args)))
4831 Error_0 ("illegal use of put"); 4720 Error_0 ("illegal use of put");
4832 4721
4833 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4722 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4834 { 4723 {
4835 if (caar (x) == y) 4724 if (caar (x) == y)
4836 break; 4725 break;
4837 } 4726 }
4838 4727
4839 if (x != NIL) 4728 if (x != NIL)
4840 cdar (x) = caddr (SCHEME_V->args); 4729 cdar (x) = caddr (args);
4841 else 4730 else
4842 symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args))); 4731 symprop (a) = cons (cons (y, caddr (args)), symprop (a));
4843 4732
4844 s_return (S_T); 4733 s_return (S_T);
4845 4734
4846 case OP_GET: /* get */ 4735 case OP_GET: /* get */
4847 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4736 if (!hasprop (a) || !hasprop (cadr (args)))
4848 Error_0 ("illegal use of get"); 4737 Error_0 ("illegal use of get");
4849 4738
4850 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4739 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4851 if (caar (x) == y) 4740 if (caar (x) == y)
4852 break; 4741 break;
4853 4742
4854 if (x != NIL) 4743 if (x != NIL)
4855 s_return (cdar (x)); 4744 s_return (cdar (x));
… …
4857 s_return (NIL); 4746 s_return (NIL);
4858 4747
4859#endif /* USE_PLIST */ 4748#endif /* USE_PLIST */
4860 4749
4861 case OP_QUIT: /* quit */ 4750 case OP_QUIT: /* quit */
4862 if (is_pair (SCHEME_V->args)) 4751 if (is_pair (args))
4863 SCHEME_V->retcode = ivalue (car (SCHEME_V->args)); 4752 SCHEME_V->retcode = ivalue (a);
4864 4753
4865 return NIL; 4754 return -1;
4866 4755
4867 case OP_GC: /* gc */ 4756 case OP_GC: /* gc */
4868 gc (SCHEME_A_ NIL, NIL); 4757 gc (SCHEME_A_ NIL, NIL);
4869 s_return (S_T); 4758 s_return (S_T);
4870 4759
4871 case OP_GCVERB: /* gc-verbose */ 4760 case OP_GCVERB: /* gc-verbose */
4872 { 4761 {
4873 int was = SCHEME_V->gc_verbose; 4762 int was = SCHEME_V->gc_verbose;
4874 4763
4875 SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F); 4764 SCHEME_V->gc_verbose = (a != S_F);
4876 s_retbool (was); 4765 s_retbool (was);
4877 } 4766 }
4878 4767
4879 case OP_NEWSEGMENT: /* new-segment */ 4768 case OP_NEWSEGMENT: /* new-segment */
4769#if 0
4880 if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args))) 4770 if (!is_pair (args) || !is_number (a))
4881 Error_0 ("new-segment: argument must be a number"); 4771 Error_0 ("new-segment: argument must be a number");
4882 4772#endif
4883 alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args))); 4773 s_retbool (alloc_cellseg (SCHEME_A));
4884
4885 s_return (S_T);
4886 4774
4887 case OP_OBLIST: /* oblist */ 4775 case OP_OBLIST: /* oblist */
4888 s_return (oblist_all_symbols (SCHEME_A)); 4776 s_return (oblist_all_symbols (SCHEME_A));
4889 4777
4890#if USE_PORTS 4778#if USE_PORTS
… …
4915 case OP_OPEN_INOUTFILE: 4803 case OP_OPEN_INOUTFILE:
4916 prop = port_input | port_output; 4804 prop = port_input | port_output;
4917 break; 4805 break;
4918 } 4806 }
4919 4807
4920 p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); 4808 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4921 4809
4922 if (p == NIL) 4810 s_return (p == NIL ? S_F : p);
4923 s_return (S_F);
4924
4925 s_return (p);
4926 } 4811 }
4927 4812
4928# if USE_STRING_PORTS 4813# if USE_STRING_PORTS
4929 4814
4930 case OP_OPEN_INSTRING: /* open-input-string */ 4815 case OP_OPEN_INSTRING: /* open-input-string */
… …
4942 case OP_OPEN_INOUTSTRING: 4827 case OP_OPEN_INOUTSTRING:
4943 prop = port_input | port_output; 4828 prop = port_input | port_output;
4944 break; 4829 break;
4945 } 4830 }
4946 4831
4947 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4832 p = port_from_string (SCHEME_A_ strvalue (a),
4948 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); 4833 strvalue (a) + strlength (a), prop);
4949 4834
4950 if (p == NIL) 4835 s_return (p == NIL ? S_F : p);
4951 s_return (S_F);
4952
4953 s_return (p);
4954 } 4836 }
4955 4837
4956 case OP_OPEN_OUTSTRING: /* open-output-string */ 4838 case OP_OPEN_OUTSTRING: /* open-output-string */
4957 { 4839 {
4958 pointer p; 4840 pointer p;
4959 4841
4960 if (car (SCHEME_V->args) == NIL) 4842 if (a == NIL)
4961 {
4962 p = port_from_scratch (SCHEME_A); 4843 p = port_from_scratch (SCHEME_A);
4963
4964 if (p == NIL)
4965 s_return (S_F);
4966 }
4967 else 4844 else
4968 {
4969 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4845 p = port_from_string (SCHEME_A_ strvalue (a),
4970 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); 4846 strvalue (a) + strlength (a), port_output);
4971 4847
4972 if (p == NIL) 4848 s_return (p == NIL ? S_F : p);
4973 s_return (S_F);
4974 }
4975
4976 s_return (p);
4977 } 4849 }
4978 4850
4979 case OP_GET_OUTSTRING: /* get-output-string */ 4851 case OP_GET_OUTSTRING: /* get-output-string */
4980 { 4852 {
4981 port *p; 4853 port *p = port (a);
4982 4854
4983 if ((p = car (SCHEME_V->args)->object.port)->kind & port_string) 4855 if (p->kind & port_string)
4984 { 4856 {
4985 off_t size; 4857 off_t size;
4986 char *str; 4858 char *str;
4987 4859
4988 size = p->rep.string.curr - p->rep.string.start + 1; 4860 size = p->rep.string.curr - p->rep.string.start + 1;
… …
5004 } 4876 }
5005 4877
5006# endif 4878# endif
5007 4879
5008 case OP_CLOSE_INPORT: /* close-input-port */ 4880 case OP_CLOSE_INPORT: /* close-input-port */
5009 port_close (SCHEME_A_ car (SCHEME_V->args), port_input); 4881 port_close (SCHEME_A_ a, port_input);
5010 s_return (S_T); 4882 s_return (S_T);
5011 4883
5012 case OP_CLOSE_OUTPORT: /* close-output-port */ 4884 case OP_CLOSE_OUTPORT: /* close-output-port */
5013 port_close (SCHEME_A_ car (SCHEME_V->args), port_output); 4885 port_close (SCHEME_A_ a, port_output);
5014 s_return (S_T); 4886 s_return (S_T);
5015#endif 4887#endif
5016 4888
5017 case OP_INT_ENV: /* interaction-environment */ 4889 case OP_INT_ENV: /* interaction-environment */
5018 s_return (SCHEME_V->global_env); 4890 s_return (SCHEME_V->global_env);
… …
5020 case OP_CURR_ENV: /* current-environment */ 4892 case OP_CURR_ENV: /* current-environment */
5021 s_return (SCHEME_V->envir); 4893 s_return (SCHEME_V->envir);
5022 4894
5023 } 4895 }
5024 4896
5025 return S_T; 4897 if (USE_ERROR_CHECKING) abort ();
5026} 4898}
5027 4899
5028static pointer 4900/* reading */
4901ecb_cold static int
5029opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4902opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5030{ 4903{
4904 pointer args = SCHEME_V->args;
5031 pointer x; 4905 pointer x;
5032 4906
5033 if (SCHEME_V->nesting != 0) 4907 if (SCHEME_V->nesting != 0)
5034 { 4908 {
5035 int n = SCHEME_V->nesting; 4909 int n = SCHEME_V->nesting;
… …
5042 switch (op) 4916 switch (op)
5043 { 4917 {
5044 /* ========== reading part ========== */ 4918 /* ========== reading part ========== */
5045#if USE_PORTS 4919#if USE_PORTS
5046 case OP_READ: 4920 case OP_READ:
5047 if (!is_pair (SCHEME_V->args)) 4921 if (!is_pair (args))
5048 s_goto (OP_READ_INTERNAL); 4922 s_goto (OP_READ_INTERNAL);
5049 4923
5050 if (!is_inport (car (SCHEME_V->args))) 4924 if (!is_inport (car (args)))
5051 Error_1 ("read: not an input port:", car (SCHEME_V->args)); 4925 Error_1 ("read: not an input port:", car (args));
5052 4926
5053 if (car (SCHEME_V->args) == SCHEME_V->inport) 4927 if (car (args) == SCHEME_V->inport)
5054 s_goto (OP_READ_INTERNAL); 4928 s_goto (OP_READ_INTERNAL);
5055 4929
5056 x = SCHEME_V->inport; 4930 x = SCHEME_V->inport;
5057 SCHEME_V->inport = car (SCHEME_V->args); 4931 SCHEME_V->inport = car (args);
5058 x = cons (x, NIL); 4932 x = cons (x, NIL);
5059 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4933 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5060 s_goto (OP_READ_INTERNAL); 4934 s_goto (OP_READ_INTERNAL);
5061 4935
5062 case OP_READ_CHAR: /* read-char */ 4936 case OP_READ_CHAR: /* read-char */
5063 case OP_PEEK_CHAR: /* peek-char */ 4937 case OP_PEEK_CHAR: /* peek-char */
5064 { 4938 {
5065 int c; 4939 int c;
5066 4940
5067 if (is_pair (SCHEME_V->args)) 4941 if (is_pair (args))
5068 { 4942 {
5069 if (car (SCHEME_V->args) != SCHEME_V->inport) 4943 if (car (args) != SCHEME_V->inport)
5070 { 4944 {
5071 x = SCHEME_V->inport; 4945 x = SCHEME_V->inport;
5072 x = cons (x, NIL); 4946 x = cons (x, NIL);
5073 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4947 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5074 SCHEME_V->inport = car (SCHEME_V->args); 4948 SCHEME_V->inport = car (args);
5075 } 4949 }
5076 } 4950 }
5077 4951
5078 c = inchar (SCHEME_A); 4952 c = inchar (SCHEME_A);
5079 4953
… …
5089 case OP_CHAR_READY: /* char-ready? */ 4963 case OP_CHAR_READY: /* char-ready? */
5090 { 4964 {
5091 pointer p = SCHEME_V->inport; 4965 pointer p = SCHEME_V->inport;
5092 int res; 4966 int res;
5093 4967
5094 if (is_pair (SCHEME_V->args)) 4968 if (is_pair (args))
5095 p = car (SCHEME_V->args); 4969 p = car (args);
5096 4970
5097 res = p->object.port->kind & port_string; 4971 res = port (p)->kind & port_string;
5098 4972
5099 s_retbool (res); 4973 s_retbool (res);
5100 } 4974 }
5101 4975
5102 case OP_SET_INPORT: /* set-input-port */ 4976 case OP_SET_INPORT: /* set-input-port */
5103 SCHEME_V->inport = car (SCHEME_V->args); 4977 SCHEME_V->inport = car (args);
5104 s_return (SCHEME_V->value); 4978 s_return (SCHEME_V->value);
5105 4979
5106 case OP_SET_OUTPORT: /* set-output-port */ 4980 case OP_SET_OUTPORT: /* set-output-port */
5107 SCHEME_V->outport = car (SCHEME_V->args); 4981 SCHEME_V->outport = car (args);
5108 s_return (SCHEME_V->value); 4982 s_return (SCHEME_V->value);
5109#endif 4983#endif
5110 4984
5111 case OP_RDSEXPR: 4985 case OP_RDSEXPR:
5112 switch (SCHEME_V->tok) 4986 switch (SCHEME_V->tok)
… …
5161 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 5035 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
5162 SCHEME_V->tok = token (SCHEME_A); 5036 SCHEME_V->tok = token (SCHEME_A);
5163 s_goto (OP_RDSEXPR); 5037 s_goto (OP_RDSEXPR);
5164 5038
5165 case TOK_ATOM: 5039 case TOK_ATOM:
5166 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 5040 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
5041
5042 case TOK_DOTATOM:
5043 SCHEME_V->strbuff[0] = '.';
5044 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5045
5046 case TOK_STRATOM:
5047 x = readstrexp (SCHEME_A_ '|');
5048 //TODO: haven't checked whether the garbage collector could interfere
5049 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5167 5050
5168 case TOK_DQUOTE: 5051 case TOK_DQUOTE:
5169 x = readstrexp (SCHEME_A); 5052 x = readstrexp (SCHEME_A_ '"');
5170 5053
5171 if (x == S_F) 5054 if (x == S_F)
5172 Error_0 ("Error reading string"); 5055 Error_0 ("Error reading string");
5173 5056
5174 setimmutable (x); 5057 setimmutable (x);
… …
5186 s_goto (OP_EVAL); 5069 s_goto (OP_EVAL);
5187 } 5070 }
5188 } 5071 }
5189 5072
5190 case TOK_SHARP_CONST: 5073 case TOK_SHARP_CONST:
5191 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 5074 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5192 Error_0 ("undefined sharp expression"); 5075 Error_0 ("undefined sharp expression");
5193 else 5076 else
5194 s_return (x); 5077 s_return (x);
5195 5078
5196 default: 5079 default:
… …
5198 } 5081 }
5199 5082
5200 break; 5083 break;
5201 5084
5202 case OP_RDLIST: 5085 case OP_RDLIST:
5203 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 5086 SCHEME_V->args = cons (SCHEME_V->value, args);
5204 SCHEME_V->tok = token (SCHEME_A); 5087 SCHEME_V->tok = token (SCHEME_A);
5205 5088
5206 switch (SCHEME_V->tok) 5089 switch (SCHEME_V->tok)
5207 { 5090 {
5208 case TOK_EOF: 5091 case TOK_EOF:
… …
5236 case OP_RDDOT: 5119 case OP_RDDOT:
5237 if (token (SCHEME_A) != TOK_RPAREN) 5120 if (token (SCHEME_A) != TOK_RPAREN)
5238 Error_0 ("syntax error: illegal dot expression"); 5121 Error_0 ("syntax error: illegal dot expression");
5239 5122
5240 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5123 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5241 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); 5124 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5242 5125
5243 case OP_RDQUOTE: 5126 case OP_RDQUOTE:
5244 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); 5127 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5245 5128
5246 case OP_RDQQUOTE: 5129 case OP_RDQQUOTE:
… …
5268 SCHEME_V->args = SCHEME_V->value; 5151 SCHEME_V->args = SCHEME_V->value;
5269 s_goto (OP_VECTOR); 5152 s_goto (OP_VECTOR);
5270 5153
5271 /* ========== printing part ========== */ 5154 /* ========== printing part ========== */
5272 case OP_P0LIST: 5155 case OP_P0LIST:
5273 if (is_vector (SCHEME_V->args)) 5156 if (is_vector (args))
5274 { 5157 {
5275 putstr (SCHEME_A_ "#("); 5158 putstr (SCHEME_A_ "#(");
5276 SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); 5159 SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5277 s_goto (OP_PVECFROM); 5160 s_goto (OP_PVECFROM);
5278 } 5161 }
5279 else if (is_environment (SCHEME_V->args)) 5162 else if (is_environment (args))
5280 { 5163 {
5281 putstr (SCHEME_A_ "#<ENVIRONMENT>"); 5164 putstr (SCHEME_A_ "#<ENVIRONMENT>");
5282 s_return (S_T); 5165 s_return (S_T);
5283 } 5166 }
5284 else if (!is_pair (SCHEME_V->args)) 5167 else if (!is_pair (args))
5285 { 5168 {
5286 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5169 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5287 s_return (S_T); 5170 s_return (S_T);
5288 } 5171 }
5289 else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5172 else
5290 { 5173 {
5174 pointer a = car (args);
5175 pointer b = cdr (args);
5176 int ok_abbr = ok_abbrev (b);
5177 SCHEME_V->args = car (b);
5178
5179 if (a == SCHEME_V->QUOTE && ok_abbr)
5291 putstr (SCHEME_A_ "'"); 5180 putstr (SCHEME_A_ "'");
5292 SCHEME_V->args = cadr (SCHEME_V->args); 5181 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5182 putstr (SCHEME_A_ "`");
5183 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5184 putstr (SCHEME_A_ ",");
5185 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5186 putstr (SCHEME_A_ ",@");
5187 else
5188 {
5189 putstr (SCHEME_A_ "(");
5190 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5191 SCHEME_V->args = a;
5192 }
5193
5293 s_goto (OP_P0LIST); 5194 s_goto (OP_P0LIST);
5294 } 5195 }
5295 else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5196
5197 case OP_P1LIST:
5198 if (is_pair (args))
5296 { 5199 {
5200 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5297 putstr (SCHEME_A_ "`"); 5201 putstr (SCHEME_A_ " ");
5298 SCHEME_V->args = cadr (SCHEME_V->args); 5202 SCHEME_V->args = car (args);
5299 s_goto (OP_P0LIST); 5203 s_goto (OP_P0LIST);
5300 } 5204 }
5301 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
5302 {
5303 putstr (SCHEME_A_ ",");
5304 SCHEME_V->args = cadr (SCHEME_V->args);
5305 s_goto (OP_P0LIST);
5306 }
5307 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
5308 {
5309 putstr (SCHEME_A_ ",@");
5310 SCHEME_V->args = cadr (SCHEME_V->args);
5311 s_goto (OP_P0LIST);
5312 }
5313 else
5314 {
5315 putstr (SCHEME_A_ "(");
5316 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5317 SCHEME_V->args = car (SCHEME_V->args);
5318 s_goto (OP_P0LIST);
5319 }
5320
5321 case OP_P1LIST:
5322 if (is_pair (SCHEME_V->args))
5323 {
5324 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5325 putstr (SCHEME_A_ " ");
5326 SCHEME_V->args = car (SCHEME_V->args);
5327 s_goto (OP_P0LIST);
5328 }
5329 else if (is_vector (SCHEME_V->args)) 5205 else if (is_vector (args))
5330 { 5206 {
5331 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); 5207 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5332 putstr (SCHEME_A_ " . "); 5208 putstr (SCHEME_A_ " . ");
5333 s_goto (OP_P0LIST); 5209 s_goto (OP_P0LIST);
5334 } 5210 }
5335 else 5211 else
5336 { 5212 {
5337 if (SCHEME_V->args != NIL) 5213 if (args != NIL)
5338 { 5214 {
5339 putstr (SCHEME_A_ " . "); 5215 putstr (SCHEME_A_ " . ");
5340 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5216 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5341 } 5217 }
5342 5218
5343 putstr (SCHEME_A_ ")"); 5219 putstr (SCHEME_A_ ")");
5344 s_return (S_T); 5220 s_return (S_T);
5345 } 5221 }
5346 5222
5347 case OP_PVECFROM: 5223 case OP_PVECFROM:
5348 { 5224 {
5349 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5225 int i = ivalue_unchecked (cdr (args));
5350 pointer vec = car (SCHEME_V->args); 5226 pointer vec = car (args);
5351 int len = veclength (vec); 5227 int len = veclength (vec);
5352 5228
5353 if (i == len) 5229 if (i == len)
5354 { 5230 {
5355 putstr (SCHEME_A_ ")"); 5231 putstr (SCHEME_A_ ")");
5356 s_return (S_T); 5232 s_return (S_T);
5357 } 5233 }
5358 else 5234 else
5359 { 5235 {
5360 pointer elem = vector_elem (vec, i); 5236 pointer elem = vector_get (vec, i);
5361 5237
5362 ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; 5238 ivalue_unchecked (cdr (args)) = i + 1;
5363 s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); 5239 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5364 SCHEME_V->args = elem; 5240 SCHEME_V->args = elem;
5365 5241
5366 if (i > 0) 5242 if (i > 0)
5367 putstr (SCHEME_A_ " "); 5243 putstr (SCHEME_A_ " ");
5368 5244
5369 s_goto (OP_P0LIST); 5245 s_goto (OP_P0LIST);
5370 } 5246 }
5371 } 5247 }
5372 } 5248 }
5373 5249
5374 return S_T; 5250 if (USE_ERROR_CHECKING) abort ();
5375} 5251}
5376 5252
5377static pointer 5253/* list ops */
5254ecb_hot static int
5378opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5255opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5379{ 5256{
5257 pointer args = SCHEME_V->args;
5258 pointer a = car (args);
5380 pointer x, y; 5259 pointer x, y;
5381 5260
5382 switch (op) 5261 switch (op)
5383 { 5262 {
5384 case OP_LIST_LENGTH: /* length *//* a.k */ 5263 case OP_LIST_LENGTH: /* length *//* a.k */
5385 { 5264 {
5386 long v = list_length (SCHEME_A_ car (SCHEME_V->args)); 5265 long v = list_length (SCHEME_A_ a);
5387 5266
5388 if (v < 0) 5267 if (v < 0)
5389 Error_1 ("length: not a list:", car (SCHEME_V->args)); 5268 Error_1 ("length: not a list:", a);
5390 5269
5391 s_return (mk_integer (SCHEME_A_ v)); 5270 s_return (mk_integer (SCHEME_A_ v));
5392 } 5271 }
5393 5272
5394 case OP_ASSQ: /* assq *//* a.k */ 5273 case OP_ASSQ: /* assq *//* a.k */
5395 x = car (SCHEME_V->args); 5274 x = a;
5396 5275
5397 for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) 5276 for (y = cadr (args); is_pair (y); y = cdr (y))
5398 { 5277 {
5399 if (!is_pair (car (y))) 5278 if (!is_pair (car (y)))
5400 Error_0 ("unable to handle non pair element"); 5279 Error_0 ("unable to handle non pair element");
5401 5280
5402 if (x == caar (y)) 5281 if (x == caar (y))
… …
5408 else 5287 else
5409 s_return (S_F); 5288 s_return (S_F);
5410 5289
5411 5290
5412 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5291 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5413 SCHEME_V->args = car (SCHEME_V->args); 5292 SCHEME_V->args = a;
5414 5293
5415 if (SCHEME_V->args == NIL) 5294 if (SCHEME_V->args == NIL)
5416 s_return (S_F); 5295 s_return (S_F);
5417 else if (is_closure (SCHEME_V->args)) 5296 else if (is_closure (SCHEME_V->args))
5418 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5297 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
… …
5423 5302
5424 case OP_CLOSUREP: /* closure? */ 5303 case OP_CLOSUREP: /* closure? */
5425 /* 5304 /*
5426 * Note, macro object is also a closure. 5305 * Note, macro object is also a closure.
5427 * Therefore, (closure? <#MACRO>) ==> #t 5306 * Therefore, (closure? <#MACRO>) ==> #t
5307 * (schmorp) well, obviously not, fix? TODO
5428 */ 5308 */
5429 s_retbool (is_closure (car (SCHEME_V->args))); 5309 s_retbool (is_closure (a));
5430 5310
5431 case OP_MACROP: /* macro? */ 5311 case OP_MACROP: /* macro? */
5432 s_retbool (is_macro (car (SCHEME_V->args))); 5312 s_retbool (is_macro (a));
5433 } 5313 }
5434 5314
5435 return S_T; /* NOTREACHED */ 5315 if (USE_ERROR_CHECKING) abort ();
5436} 5316}
5437 5317
5318/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5438typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5319typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5439 5320
5440typedef int (*test_predicate) (pointer); 5321typedef int (*test_predicate)(pointer);
5441static int 5322
5323ecb_hot static int
5442is_any (pointer p) 5324tst_any (pointer p)
5443{ 5325{
5444 return 1; 5326 return 1;
5445} 5327}
5446 5328
5447static int 5329ecb_hot static int
5448is_nonneg (pointer p) 5330tst_inonneg (pointer p)
5449{ 5331{
5450 return ivalue (p) >= 0 && is_integer (p); 5332 return is_integer (p) && ivalue_unchecked (p) >= 0;
5333}
5334
5335ecb_hot static int
5336tst_is_list (SCHEME_P_ pointer p)
5337{
5338 return p == NIL || is_pair (p);
5451} 5339}
5452 5340
5453/* Correspond carefully with following defines! */ 5341/* Correspond carefully with following defines! */
5454static struct 5342static struct
5455{ 5343{
5456 test_predicate fct; 5344 test_predicate fct;
5457 const char *kind; 5345 const char *kind;
5458} tests[] = 5346} tests[] = {
5459{ 5347 { tst_any , 0 },
5460 { 0, 0}, /* unused */ 5348 { is_string , "string" },
5461 { is_any, 0}, 5349 { is_symbol , "symbol" },
5462 { is_string, "string" }, 5350 { is_port , "port" },
5463 { is_symbol, "symbol" },
5464 { is_port, "port" },
5465 { is_inport, "input port" }, 5351 { is_inport , "input port" },
5466 { is_outport, "output port" }, 5352 { is_outport , "output port" },
5467 { is_environment, "environment" }, 5353 { is_environment, "environment" },
5468 { is_pair, "pair" }, 5354 { is_pair , "pair" },
5469 { 0, "pair or '()" }, 5355 { 0 , "pair or '()" },
5470 { is_character, "character" }, 5356 { is_character , "character" },
5471 { is_vector, "vector" }, 5357 { is_vector , "vector" },
5472 { is_number, "number" }, 5358 { is_number , "number" },
5473 { is_integer, "integer" }, 5359 { is_integer , "integer" },
5474 { is_nonneg, "non-negative integer" } 5360 { tst_inonneg , "non-negative integer" }
5475}; 5361};
5476 5362
5477#define TST_NONE 0 5363#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5478#define TST_ANY "\001" 5364#define TST_ANY "\001"
5479#define TST_STRING "\002" 5365#define TST_STRING "\002"
5480#define TST_SYMBOL "\003" 5366#define TST_SYMBOL "\003"
5481#define TST_PORT "\004" 5367#define TST_PORT "\004"
5482#define TST_INPORT "\005" 5368#define TST_INPORT "\005"
5483#define TST_OUTPORT "\006" 5369#define TST_OUTPORT "\006"
5484#define TST_ENVIRONMENT "\007" 5370#define TST_ENVIRONMENT "\007"
5485#define TST_PAIR "\010" 5371#define TST_PAIR "\010"
5486#define TST_LIST "\011" 5372#define TST_LIST "\011"
5487#define TST_CHAR "\012" 5373#define TST_CHAR "\012"
5488#define TST_VECTOR "\013" 5374#define TST_VECTOR "\013"
5489#define TST_NUMBER "\014" 5375#define TST_NUMBER "\014"
5490#define TST_INTEGER "\015" 5376#define TST_INTEGER "\015"
5491#define TST_NATURAL "\016" 5377#define TST_NATURAL "\016"
5378
5379#define INF_ARG 0xff
5380#define UNNAMED_OP ""
5381
5382static const char opnames[] =
5383#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5384#include "opdefines.h"
5385#undef OP_DEF
5386;
5387
5388ecb_cold static const char *
5389opname (int idx)
5390{
5391 const char *name = opnames;
5392
5393 /* should do this at compile time, but would require external program, right? */
5394 while (idx--)
5395 name += strlen (name) + 1;
5396
5397 return *name ? name : "ILLEGAL";
5398}
5399
5400ecb_cold static const char *
5401procname (pointer x)
5402{
5403 return opname (procnum (x));
5404}
5492 5405
5493typedef struct 5406typedef struct
5494{ 5407{
5495 dispatch_func func; 5408 uint8_t func;
5496 char *name; 5409 /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5410 uint8_t builtin;
5411#if USE_ERROR_CHECKING
5497 int min_arity; 5412 uint8_t min_arity;
5498 int max_arity; 5413 uint8_t max_arity;
5499 char *arg_tests_encoding; 5414 char arg_tests_encoding[3];
5415#endif
5500} op_code_info; 5416} op_code_info;
5501 5417
5502#define INF_ARG 0xffff
5503
5504static op_code_info dispatch_table[] = { 5418static const op_code_info dispatch_table[] = {
5505#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, 5419#if USE_ERROR_CHECKING
5420#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5421#else
5422#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
5423#endif
5506#include "opdefines.h" 5424#include "opdefines.h"
5425#undef OP_DEF
5507 {0} 5426 {0}
5508}; 5427};
5509 5428
5510static const char *
5511procname (pointer x)
5512{
5513 int n = procnum (x);
5514 const char *name = dispatch_table[n].name;
5515
5516 if (name == 0)
5517 name = "ILLEGAL!";
5518
5519 return name;
5520}
5521
5522/* kernel of this interpreter */ 5429/* kernel of this interpreter */
5523static void 5430ecb_hot static void
5524Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5431Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5525{ 5432{
5526 SCHEME_V->op = op; 5433 SCHEME_V->op = op;
5527 5434
5528 for (;;) 5435 for (;;)
5529 { 5436 {
5530 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5437 const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5531 5438
5532#if USE_ERROR_CHECKING 5439#if USE_ERROR_CHECKING
5533 if (pcd->name) /* if built-in function, check arguments */ 5440 if (pcd->builtin) /* if built-in function, check arguments */
5534 { 5441 {
5535 int ok = 1;
5536 char msg[STRBUFFSIZE]; 5442 char msg[STRBUFFSIZE];
5537 int n = list_length (SCHEME_A_ SCHEME_V->args); 5443 int n = list_length (SCHEME_A_ SCHEME_V->args);
5538 5444
5539 /* Check number of arguments */ 5445 /* Check number of arguments */
5540 if (n < pcd->min_arity) 5446 if (ecb_expect_false (n < pcd->min_arity))
5541 { 5447 {
5542 ok = 0;
5543 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5448 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5544 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5449 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5450 xError_1 (SCHEME_A_ msg, 0);
5451 continue;
5545 } 5452 }
5546 5453 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5547 if (ok && n > pcd->max_arity)
5548 { 5454 {
5549 ok = 0;
5550 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5455 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5551 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5456 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5457 xError_1 (SCHEME_A_ msg, 0);
5458 continue;
5552 } 5459 }
5553 5460 else
5554 if (ok)
5555 { 5461 {
5556 if (pcd->arg_tests_encoding) 5462 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5557 { 5463 {
5558 int i = 0; 5464 int i = 0;
5559 int j; 5465 int j;
5560 const char *t = pcd->arg_tests_encoding; 5466 const char *t = pcd->arg_tests_encoding;
5561 pointer arglist = SCHEME_V->args; 5467 pointer arglist = SCHEME_V->args;
5562 5468
5563 do 5469 do
5564 { 5470 {
5565 pointer arg = car (arglist); 5471 pointer arg = car (arglist);
5566 5472
5567 j = (int) t[0]; 5473 j = t[0];
5568 5474
5475 /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
5569 if (j == TST_LIST[0]) 5476 if (j == TST_LIST[0])
5570 { 5477 {
5571 if (arg != NIL && !is_pair (arg)) 5478 if (!tst_is_list (SCHEME_A_ arg))
5572 break; 5479 break;
5573 } 5480 }
5574 else 5481 else
5575 { 5482 {
5576 if (!tests[j].fct (arg)) 5483 if (!tests[j - 1].fct (arg))
5577 break; 5484 break;
5578 } 5485 }
5579 5486
5580 if (t[1] != 0) /* last test is replicated as necessary */ 5487 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5581 t++; 5488 t++;
5582 5489
5583 arglist = cdr (arglist); 5490 arglist = cdr (arglist);
5584 i++; 5491 i++;
5585 } 5492 }
5586 while (i < n); 5493 while (i < n);
5587 5494
5588 if (i < n) 5495 if (i < n)
5589 { 5496 {
5590 ok = 0;
5591 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); 5497 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
5498 xError_1 (SCHEME_A_ msg, 0);
5499 continue;
5592 } 5500 }
5593 } 5501 }
5594 } 5502 }
5595
5596 if (!ok)
5597 {
5598 if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5599 return;
5600
5601 pcd = dispatch_table + SCHEME_V->op;
5602 }
5603 } 5503 }
5604#endif 5504#endif
5605 5505
5606 ok_to_freely_gc (SCHEME_A); 5506 ok_to_freely_gc (SCHEME_A);
5607 5507
5608 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5508 static const dispatch_func dispatch_funcs[] = {
5509 opexe_0,
5510 opexe_1,
5511 opexe_2,
5512 opexe_3,
5513 opexe_4,
5514 opexe_5,
5515 opexe_6,
5516 };
5517
5518 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5609 return; 5519 return;
5610 5520
5611 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5521 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5612 { 5522 {
5613 xwrstr ("No memory!\n"); 5523 putstr (SCHEME_A_ "No memory!\n");
5614 return; 5524 return;
5615 } 5525 }
5616 } 5526 }
5617} 5527}
5618 5528
5619/* ========== Initialization of internal keywords ========== */ 5529/* ========== Initialization of internal keywords ========== */
5620 5530
5621static void 5531ecb_cold static void
5622assign_syntax (SCHEME_P_ const char *name) 5532assign_syntax (SCHEME_P_ const char *name)
5623{ 5533{
5624 pointer x = oblist_add_by_name (SCHEME_A_ name); 5534 pointer x = oblist_add_by_name (SCHEME_A_ name);
5625 set_typeflag (x, typeflag (x) | T_SYNTAX); 5535 set_typeflag (x, typeflag (x) | T_SYNTAX);
5626} 5536}
5627 5537
5628static void 5538ecb_cold static void
5629assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5539assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5630{ 5540{
5631 pointer x = mk_symbol (SCHEME_A_ name); 5541 pointer x = mk_symbol (SCHEME_A_ name);
5632 pointer y = mk_proc (SCHEME_A_ op); 5542 pointer y = mk_proc (SCHEME_A_ op);
5633 new_slot_in_env (SCHEME_A_ x, y); 5543 new_slot_in_env (SCHEME_A_ x, y);
… …
5637mk_proc (SCHEME_P_ enum scheme_opcodes op) 5547mk_proc (SCHEME_P_ enum scheme_opcodes op)
5638{ 5548{
5639 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5549 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5640 set_typeflag (y, (T_PROC | T_ATOM)); 5550 set_typeflag (y, (T_PROC | T_ATOM));
5641 ivalue_unchecked (y) = op; 5551 ivalue_unchecked (y) = op;
5642 set_num_integer (y);
5643 return y; 5552 return y;
5644} 5553}
5645 5554
5646/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5555/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5647static int 5556ecb_hot static int
5648syntaxnum (pointer p) 5557syntaxnum (pointer p)
5649{ 5558{
5650 const char *s = strvalue (car (p)); 5559 const char *s = strvalue (p);
5651 5560
5652 switch (strlength (car (p))) 5561 switch (strlength (p))
5653 { 5562 {
5654 case 2: 5563 case 2:
5655 if (s[0] == 'i') 5564 if (s[0] == 'i')
5656 return OP_IF0; /* if */ 5565 return OP_IF0; /* if */
5657 else 5566 else
… …
5671 5580
5672 case 'd': 5581 case 'd':
5673 return OP_COND0; /* cond */ 5582 return OP_COND0; /* cond */
5674 5583
5675 case '*': 5584 case '*':
5676 return OP_LET0AST; /* let* */ 5585 return OP_LET0AST;/* let* */
5677 5586
5678 default: 5587 default:
5679 return OP_SET0; /* set! */ 5588 return OP_SET0; /* set! */
5680 } 5589 }
5681 5590
… …
5703 5612
5704 case 'f': 5613 case 'f':
5705 return OP_DEF0; /* define */ 5614 return OP_DEF0; /* define */
5706 5615
5707 default: 5616 default:
5708 return OP_LET0REC; /* letrec */ 5617 return OP_LET0REC;/* letrec */
5709 } 5618 }
5710 5619
5711 default: 5620 default:
5712 return OP_C0STREAM; /* cons-stream */ 5621 return OP_C0STREAM; /* cons-stream */
5713 } 5622 }
5714} 5623}
5715 5624
5716#if USE_MULTIPLICITY 5625#if USE_MULTIPLICITY
5717scheme * 5626ecb_cold scheme *
5718scheme_init_new () 5627scheme_init_new ()
5719{ 5628{
5720 scheme *sc = malloc (sizeof (scheme)); 5629 scheme *sc = malloc (sizeof (scheme));
5721 5630
5722 if (!scheme_init (SCHEME_A)) 5631 if (!scheme_init (SCHEME_A))
… …
5727 else 5636 else
5728 return sc; 5637 return sc;
5729} 5638}
5730#endif 5639#endif
5731 5640
5732int 5641ecb_cold int
5733scheme_init (SCHEME_P) 5642scheme_init (SCHEME_P)
5734{ 5643{
5735 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5644 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5736 pointer x; 5645 pointer x;
5646
5647 /* this memset is not strictly correct, as we assume (intcache)
5648 * that memset 0 will also set pointers to 0, but memset does
5649 * of course not guarantee that. screw such systems.
5650 */
5651 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5737 5652
5738 num_set_fixnum (num_zero, 1); 5653 num_set_fixnum (num_zero, 1);
5739 num_set_ivalue (num_zero, 0); 5654 num_set_ivalue (num_zero, 0);
5740 num_set_fixnum (num_one, 1); 5655 num_set_fixnum (num_one, 1);
5741 num_set_ivalue (num_one, 1); 5656 num_set_ivalue (num_one, 1);
… …
5753 SCHEME_V->save_inport = NIL; 5668 SCHEME_V->save_inport = NIL;
5754 SCHEME_V->loadport = NIL; 5669 SCHEME_V->loadport = NIL;
5755 SCHEME_V->nesting = 0; 5670 SCHEME_V->nesting = 0;
5756 SCHEME_V->interactive_repl = 0; 5671 SCHEME_V->interactive_repl = 0;
5757 5672
5758 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5673 if (!alloc_cellseg (SCHEME_A))
5759 { 5674 {
5760#if USE_ERROR_CHECKING 5675#if USE_ERROR_CHECKING
5761 SCHEME_V->no_memory = 1; 5676 SCHEME_V->no_memory = 1;
5762 return 0; 5677 return 0;
5763#endif 5678#endif
… …
5810 5725
5811 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) 5726 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5812 assign_syntax (SCHEME_A_ syntax_names[i]); 5727 assign_syntax (SCHEME_A_ syntax_names[i]);
5813 } 5728 }
5814 5729
5730 // TODO: should iterate via strlen, to avoid n² complexity
5815 for (i = 0; i < n; i++) 5731 for (i = 0; i < n; i++)
5816 if (dispatch_table[i].name != 0) 5732 if (dispatch_table[i].builtin)
5817 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5733 assign_proc (SCHEME_A_ i, opname (i));
5818 5734
5819 /* initialization of global pointers to special symbols */ 5735 /* initialization of global pointers to special symbols */
5820 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5736 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5821 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5737 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5822 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5738 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
… …
5830 5746
5831 return !SCHEME_V->no_memory; 5747 return !SCHEME_V->no_memory;
5832} 5748}
5833 5749
5834#if USE_PORTS 5750#if USE_PORTS
5835void 5751ecb_cold void
5836scheme_set_input_port_file (SCHEME_P_ int fin) 5752scheme_set_input_port_file (SCHEME_P_ int fin)
5837{ 5753{
5838 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5754 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5839} 5755}
5840 5756
5841void 5757ecb_cold void
5842scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5758scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5843{ 5759{
5844 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5760 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5845} 5761}
5846 5762
5847void 5763ecb_cold void
5848scheme_set_output_port_file (SCHEME_P_ int fout) 5764scheme_set_output_port_file (SCHEME_P_ int fout)
5849{ 5765{
5850 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5766 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5851} 5767}
5852 5768
5853void 5769ecb_cold void
5854scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5770scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5855{ 5771{
5856 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5772 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5857} 5773}
5858#endif 5774#endif
5859 5775
5860void 5776ecb_cold void
5861scheme_set_external_data (SCHEME_P_ void *p) 5777scheme_set_external_data (SCHEME_P_ void *p)
5862{ 5778{
5863 SCHEME_V->ext_data = p; 5779 SCHEME_V->ext_data = p;
5864} 5780}
5865 5781
5866void 5782ecb_cold void
5867scheme_deinit (SCHEME_P) 5783scheme_deinit (SCHEME_P)
5868{ 5784{
5869 int i; 5785 int i;
5870 5786
5871#if SHOW_ERROR_LINE 5787#if SHOW_ERROR_LINE
… …
5913 } 5829 }
5914 } 5830 }
5915#endif 5831#endif
5916} 5832}
5917 5833
5918void 5834ecb_cold void
5919scheme_load_file (SCHEME_P_ int fin) 5835scheme_load_file (SCHEME_P_ int fin)
5920{ 5836{
5921 scheme_load_named_file (SCHEME_A_ fin, 0); 5837 scheme_load_named_file (SCHEME_A_ fin, 0);
5922} 5838}
5923 5839
5924void 5840ecb_cold void
5925scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5841scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5926{ 5842{
5927 dump_stack_reset (SCHEME_A); 5843 dump_stack_reset (SCHEME_A);
5928 SCHEME_V->envir = SCHEME_V->global_env; 5844 SCHEME_V->envir = SCHEME_V->global_env;
5929 SCHEME_V->file_i = 0; 5845 SCHEME_V->file_i = 0;
… …
5956 5872
5957 if (SCHEME_V->retcode == 0) 5873 if (SCHEME_V->retcode == 0)
5958 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5874 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5959} 5875}
5960 5876
5961void 5877ecb_cold void
5962scheme_load_string (SCHEME_P_ const char *cmd) 5878scheme_load_string (SCHEME_P_ const char *cmd)
5963{ 5879{
5964 dump_stack_reset (SCHEME_A); 5880 dump_stack_reset (SCHEME_A);
5965 SCHEME_V->envir = SCHEME_V->global_env; 5881 SCHEME_V->envir = SCHEME_V->global_env;
5966 SCHEME_V->file_i = 0; 5882 SCHEME_V->file_i = 0;
5967 SCHEME_V->load_stack[0].kind = port_input | port_string; 5883 SCHEME_V->load_stack[0].kind = port_input | port_string;
5968 SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */ 5884 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5969 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd); 5885 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5970 SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd; 5886 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5971#if USE_PORTS 5887#if USE_PORTS
5972 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5888 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5973#endif 5889#endif
5974 SCHEME_V->retcode = 0; 5890 SCHEME_V->retcode = 0;
5975 SCHEME_V->interactive_repl = 0; 5891 SCHEME_V->interactive_repl = 0;
… …
5980 5896
5981 if (SCHEME_V->retcode == 0) 5897 if (SCHEME_V->retcode == 0)
5982 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5898 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5983} 5899}
5984 5900
5985void 5901ecb_cold void
5986scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 5902scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5987{ 5903{
5988 pointer x; 5904 pointer x;
5989 5905
5990 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 5906 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5995 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 5911 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5996} 5912}
5997 5913
5998#if !STANDALONE 5914#if !STANDALONE
5999 5915
6000void 5916ecb_cold void
6001scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 5917scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
6002{ 5918{
6003 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 5919 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
6004} 5920}
6005 5921
6006void 5922ecb_cold void
6007scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 5923scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
6008{ 5924{
6009 int i; 5925 int i;
6010 5926
6011 for (i = 0; i < count; i++) 5927 for (i = 0; i < count; i++)
6012 scheme_register_foreign_func (SCHEME_A_ list + i); 5928 scheme_register_foreign_func (SCHEME_A_ list + i);
6013} 5929}
6014 5930
6015pointer 5931ecb_cold pointer
6016scheme_apply0 (SCHEME_P_ const char *procname) 5932scheme_apply0 (SCHEME_P_ const char *procname)
6017{ 5933{
6018 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 5934 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
6019} 5935}
6020 5936
6021void 5937ecb_cold void
6022save_from_C_call (SCHEME_P) 5938save_from_C_call (SCHEME_P)
6023{ 5939{
6024 pointer saved_data = cons (car (S_SINK), 5940 pointer saved_data = cons (car (S_SINK),
6025 cons (SCHEME_V->envir, 5941 cons (SCHEME_V->envir,
6026 SCHEME_V->dump)); 5942 SCHEME_V->dump));
… …
6030 /* Truncate the dump stack so TS will return here when done, not 5946 /* Truncate the dump stack so TS will return here when done, not
6031 directly resume pre-C-call operations. */ 5947 directly resume pre-C-call operations. */
6032 dump_stack_reset (SCHEME_A); 5948 dump_stack_reset (SCHEME_A);
6033} 5949}
6034 5950
6035void 5951ecb_cold void
6036restore_from_C_call (SCHEME_P) 5952restore_from_C_call (SCHEME_P)
6037{ 5953{
6038 set_car (S_SINK, caar (SCHEME_V->c_nest)); 5954 set_car (S_SINK, caar (SCHEME_V->c_nest));
6039 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 5955 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
6040 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 5956 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
6041 /* Pop */ 5957 /* Pop */
6042 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 5958 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
6043} 5959}
6044 5960
6045/* "func" and "args" are assumed to be already eval'ed. */ 5961/* "func" and "args" are assumed to be already eval'ed. */
6046pointer 5962ecb_cold pointer
6047scheme_call (SCHEME_P_ pointer func, pointer args) 5963scheme_call (SCHEME_P_ pointer func, pointer args)
6048{ 5964{
6049 int old_repl = SCHEME_V->interactive_repl; 5965 int old_repl = SCHEME_V->interactive_repl;
6050 5966
6051 SCHEME_V->interactive_repl = 0; 5967 SCHEME_V->interactive_repl = 0;
… …
6058 SCHEME_V->interactive_repl = old_repl; 5974 SCHEME_V->interactive_repl = old_repl;
6059 restore_from_C_call (SCHEME_A); 5975 restore_from_C_call (SCHEME_A);
6060 return SCHEME_V->value; 5976 return SCHEME_V->value;
6061} 5977}
6062 5978
6063pointer 5979ecb_cold pointer
6064scheme_eval (SCHEME_P_ pointer obj) 5980scheme_eval (SCHEME_P_ pointer obj)
6065{ 5981{
6066 int old_repl = SCHEME_V->interactive_repl; 5982 int old_repl = SCHEME_V->interactive_repl;
6067 5983
6068 SCHEME_V->interactive_repl = 0; 5984 SCHEME_V->interactive_repl = 0;
… …
6080 5996
6081/* ========== Main ========== */ 5997/* ========== Main ========== */
6082 5998
6083#if STANDALONE 5999#if STANDALONE
6084 6000
6085int 6001ecb_cold int
6086main (int argc, char **argv) 6002main (int argc, char **argv)
6087{ 6003{
6088# if USE_MULTIPLICITY 6004# if USE_MULTIPLICITY
6089 scheme ssc; 6005 scheme ssc;
6090 scheme *const SCHEME_V = &ssc; 6006 scheme *const SCHEME_V = &ssc;
… …
6092# endif 6008# endif
6093 int fin; 6009 int fin;
6094 char *file_name = InitFile; 6010 char *file_name = InitFile;
6095 int retcode; 6011 int retcode;
6096 int isfile = 1; 6012 int isfile = 1;
6013 system ("ps v $PPID");//D
6097 6014
6098 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6015 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6099 { 6016 {
6100 xwrstr ("Usage: tinyscheme -?\n"); 6017 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6101 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6018 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6102 xwrstr ("followed by\n"); 6019 putstr (SCHEME_A_ "followed by\n");
6103 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6020 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6104 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6021 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6105 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6022 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6106 xwrstr ("Use - as filename for stdin.\n"); 6023 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6107 return 1; 6024 return 1;
6108 } 6025 }
6109 6026
6110 if (!scheme_init (SCHEME_A)) 6027 if (!scheme_init (SCHEME_A))
6111 { 6028 {
6112 xwrstr ("Could not initialize!\n"); 6029 putstr (SCHEME_A_ "Could not initialize!\n");
6113 return 2; 6030 return 2;
6114 } 6031 }
6115 6032
6116# if USE_PORTS 6033# if USE_PORTS
6117 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6034 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6162 fin = open (file_name, O_RDONLY); 6079 fin = open (file_name, O_RDONLY);
6163#endif 6080#endif
6164 6081
6165 if (isfile && fin < 0) 6082 if (isfile && fin < 0)
6166 { 6083 {
6167 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6084 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6168 } 6085 }
6169 else 6086 else
6170 { 6087 {
6171 if (isfile) 6088 if (isfile)
6172 scheme_load_named_file (SCHEME_A_ fin, file_name); 6089 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6176#if USE_PORTS 6093#if USE_PORTS
6177 if (!isfile || fin != STDIN_FILENO) 6094 if (!isfile || fin != STDIN_FILENO)
6178 { 6095 {
6179 if (SCHEME_V->retcode != 0) 6096 if (SCHEME_V->retcode != 0)
6180 { 6097 {
6181 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6098 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6182 } 6099 }
6183 6100
6184 if (isfile) 6101 if (isfile)
6185 close (fin); 6102 close (fin);
6186 } 6103 }

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines