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.19 by root, Thu Nov 26 21:36:11 2015 UTC vs.
Revision 1.29 by root, Sat Nov 28 10:31:06 2015 UTC

… …
28#endif 28#endif
29#if USE_MATH 29#if USE_MATH
30# include <math.h> 30# include <math.h>
31#endif 31#endif
32 32
33#include "ecb.h"
34
33#include <sys/types.h> 35#include <sys/types.h>
34#include <sys/stat.h> 36#include <sys/stat.h>
35#include <fcntl.h> 37#include <fcntl.h>
36 38
37#include <string.h> 39#include <string.h>
… …
65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 67#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 68#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67#define S_SINK (&SCHEME_V->xsink) 69#define S_SINK (&SCHEME_V->xsink)
68#define S_EOF (&SCHEME_V->xEOF_OBJ) 70#define S_EOF (&SCHEME_V->xEOF_OBJ)
69 71
70/* should use libecb */
71#if __GNUC__ >= 4
72# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74# define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
75#else
76# define ecb_expect_false(expr) !!(expr)
77# define ecb_expect_true(expr) !!(expr)
78#endif
79
80#if !USE_MULTIPLICITY 72#if !USE_MULTIPLICITY
81static scheme sc; 73static scheme sc;
82#endif 74#endif
83 75
84static void 76static void
… …
153 145
154#define toupper(c) xtoupper (c) 146#define toupper(c) xtoupper (c)
155#define tolower(c) xtolower (c) 147#define tolower(c) xtolower (c)
156#define isdigit(c) xisdigit (c) 148#define isdigit(c) xisdigit (c)
157 149
158#if USE_STRLWR 150#if USE_IGNORECASE
159static const char * 151static const char *
160strlwr (char *s) 152xstrlwr (char *s)
161{ 153{
162 const char *p = s; 154 const char *p = s;
163 155
164 while (*s) 156 while (*s)
165 { 157 {
… …
167 s++; 159 s++;
168 } 160 }
169 161
170 return p; 162 return p;
171} 163}
172#endif
173 164
165#define stricmp(a,b) strcasecmp (a, b)
166#define strlwr(s) xstrlwr (s)
167
168#else
174#define stricmp(a,b) strcmp (a, b) 169# define stricmp(a,b) strcmp (a, b)
175#define strlwr(s) (s) 170# define strlwr(s) (s)
171#endif
176 172
177#ifndef prompt 173#ifndef prompt
178# define prompt "ts> " 174# define prompt "ts> "
179#endif 175#endif
180 176
… …
186# define FIRST_CELLSEGS 3 182# define FIRST_CELLSEGS 3
187#endif 183#endif
188 184
189enum scheme_types 185enum scheme_types
190{ 186{
187 T_INTEGER,
191 T_FREE, 188 T_REAL,
192 T_STRING, 189 T_STRING,
193 T_NUMBER,
194 T_SYMBOL, 190 T_SYMBOL,
195 T_PROC, 191 T_PROC,
196 T_PAIR, 192 T_PAIR, /* also used for free cells */
197 T_CLOSURE, 193 T_CLOSURE,
198 T_CONTINUATION, 194 T_CONTINUATION,
199 T_FOREIGN, 195 T_FOREIGN,
200 T_CHARACTER, 196 T_CHARACTER,
201 T_PORT, 197 T_PORT,
… …
211#define T_SYNTAX 0x0010 207#define T_SYNTAX 0x0010
212#define T_IMMUTABLE 0x0020 208#define T_IMMUTABLE 0x0020
213#define T_ATOM 0x0040 /* only for gc */ 209#define T_ATOM 0x0040 /* only for gc */
214#define T_MARK 0x0080 /* only for gc */ 210#define T_MARK 0x0080 /* only for gc */
215 211
212/* num, for generic arithmetic */
213struct num
214{
215 IVALUE ivalue;
216#if USE_REAL
217 RVALUE rvalue;
218 char is_fixnum;
219#endif
220};
221
222#if USE_REAL
223# define num_is_fixnum(n) (n).is_fixnum
224# define num_set_fixnum(n,f) (n).is_fixnum = (f)
225# define num_ivalue(n) (n).ivalue
226# define num_rvalue(n) (n).rvalue
227# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
228# define num_set_rvalue(n,r) (n).rvalue = (r)
229#else
230# define num_is_fixnum(n) 1
231# define num_set_fixnum(n,f) 0
232# define num_ivalue(n) (n).ivalue
233# define num_rvalue(n) (n).ivalue
234# define num_set_ivalue(n,i) (n).ivalue = (i)
235# define num_set_rvalue(n,r) (n).ivalue = (r)
236#endif
237
216enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV }; 238enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
217 239
218static num num_op (enum num_op op, num a, num b); 240static num num_op (enum num_op op, num a, num b);
219static num num_intdiv (num a, num b); 241static num num_intdiv (num a, num b);
220static num num_rem (num a, num b); 242static num num_rem (num a, num b);
… …
223#if USE_MATH 245#if USE_MATH
224static double round_per_R5RS (double x); 246static double round_per_R5RS (double x);
225#endif 247#endif
226static int is_zero_rvalue (RVALUE x); 248static int is_zero_rvalue (RVALUE x);
227 249
228static INLINE int
229num_is_integer (pointer p)
230{
231 return num_is_fixnum (p->object.number);
232}
233
234static num num_zero; 250static num num_zero;
235static num num_one; 251static num num_one;
236 252
237/* macros for cell operations */ 253/* macros for cell operations */
238#define typeflag(p) ((p)->flag + 0) 254#define typeflag(p) ((p)->flag + 0)
239#define set_typeflag(p,v) ((p)->flag = (v)) 255#define set_typeflag(p,v) ((p)->flag = (v))
240#define type(p) (typeflag (p) & T_MASKTYPE) 256#define type(p) (typeflag (p) & T_MASKTYPE)
241 257
242INTERFACE INLINE int 258INTERFACE int
243is_string (pointer p) 259is_string (pointer p)
244{ 260{
245 return type (p) == T_STRING; 261 return type (p) == T_STRING;
246} 262}
247 263
248#define strvalue(p) ((p)->object.string.svalue) 264#define strvalue(p) ((p)->object.string.svalue)
249#define strlength(p) ((p)->object.string.length) 265#define strlength(p) ((p)->object.string.length)
250 266
251INTERFACE int is_list (SCHEME_P_ pointer p);
252
253INTERFACE INLINE int 267INTERFACE int
254is_vector (pointer p) 268is_vector (pointer p)
255{ 269{
256 return type (p) == T_VECTOR; 270 return type (p) == T_VECTOR;
257} 271}
258 272
259#define vecvalue(p) ((p)->object.vector.vvalue) 273#define vecvalue(p) ((p)->object.vector.vvalue)
260#define veclength(p) ((p)->object.vector.length) 274#define veclength(p) ((p)->object.vector.length)
261INTERFACE void fill_vector (pointer vec, pointer obj); 275INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
262INTERFACE uint32_t vector_length (pointer vec);
263INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 276INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
264INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 277INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
265 278
266INTERFACE uint32_t 279INTERFACE int
267vector_length (pointer vec) 280is_integer (pointer p)
268{ 281{
269 return vec->object.vector.length; 282 return type (p) == T_INTEGER;
270} 283}
271 284
285/* not the same as in scheme, where integers are (correctly :) reals */
272INTERFACE INLINE int 286INTERFACE int
287is_real (pointer p)
288{
289 return type (p) == T_REAL;
290}
291
292INTERFACE int
273is_number (pointer p) 293is_number (pointer p)
274{ 294{
275 return type (p) == T_NUMBER; 295 return is_integer (p) || is_real (p);
276} 296}
277 297
278INTERFACE INLINE int 298INTERFACE int
279is_integer (pointer p)
280{
281 if (!is_number (p))
282 return 0;
283
284 if (num_is_integer (p) || ivalue (p) == rvalue (p))
285 return 1;
286
287 return 0;
288}
289
290INTERFACE INLINE int
291is_real (pointer p)
292{
293 return is_number (p) && !num_is_fixnum (p->object.number);
294}
295
296INTERFACE INLINE int
297is_character (pointer p) 299is_character (pointer p)
298{ 300{
299 return type (p) == T_CHARACTER; 301 return type (p) == T_CHARACTER;
300} 302}
301 303
302INTERFACE INLINE char * 304INTERFACE char *
303string_value (pointer p) 305string_value (pointer p)
304{ 306{
305 return strvalue (p); 307 return strvalue (p);
306} 308}
307 309
308INLINE num
309nvalue (pointer p)
310{
311 return (p)->object.number;
312}
313
314static IVALUE
315num_get_ivalue (const num n)
316{
317 return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
318}
319
320static RVALUE
321num_get_rvalue (const num n)
322{
323 return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
324}
325
326INTERFACE IVALUE
327ivalue (pointer p)
328{
329 return num_get_ivalue (p->object.number);
330}
331
332INTERFACE RVALUE
333rvalue (pointer p)
334{
335 return num_get_rvalue (p->object.number);
336}
337
338#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 310#define ivalue_unchecked(p) (p)->object.ivalue
311#define set_ivalue(p,v) (p)->object.ivalue = (v)
312
339#if USE_REAL 313#if USE_REAL
340# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 314#define rvalue_unchecked(p) (p)->object.rvalue
341# define set_num_integer(p) (p)->object.number.is_fixnum=1; 315#define set_rvalue(p,v) (p)->object.rvalue = (v)
342# define set_num_real(p) (p)->object.number.is_fixnum=0;
343#else 316#else
344# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 317#define rvalue_unchecked(p) (p)->object.ivalue
345# define set_num_integer(p) 0 318#define set_rvalue(p,v) (p)->object.ivalue = (v)
346# define set_num_real(p) 0
347#endif 319#endif
320
348INTERFACE long 321INTERFACE long
349charvalue (pointer p) 322charvalue (pointer p)
350{ 323{
351 return ivalue_unchecked (p); 324 return ivalue_unchecked (p);
352} 325}
353 326
354INTERFACE INLINE int 327INTERFACE int
355is_port (pointer p) 328is_port (pointer p)
356{ 329{
357 return type (p) == T_PORT; 330 return type (p) == T_PORT;
358} 331}
359 332
360INTERFACE INLINE int 333INTERFACE int
361is_inport (pointer p) 334is_inport (pointer p)
362{ 335{
363 return is_port (p) && p->object.port->kind & port_input; 336 return is_port (p) && p->object.port->kind & port_input;
364} 337}
365 338
366INTERFACE INLINE int 339INTERFACE int
367is_outport (pointer p) 340is_outport (pointer p)
368{ 341{
369 return is_port (p) && p->object.port->kind & port_output; 342 return is_port (p) && p->object.port->kind & port_output;
370} 343}
371 344
372INTERFACE INLINE int 345INTERFACE int
373is_pair (pointer p) 346is_pair (pointer p)
374{ 347{
375 return type (p) == T_PAIR; 348 return type (p) == T_PAIR;
376} 349}
377 350
… …
409pair_cdr (pointer p) 382pair_cdr (pointer p)
410{ 383{
411 return cdr (p); 384 return cdr (p);
412} 385}
413 386
414INTERFACE INLINE int 387INTERFACE int
415is_symbol (pointer p) 388is_symbol (pointer p)
416{ 389{
417 return type (p) == T_SYMBOL; 390 return type (p) == T_SYMBOL;
418} 391}
419 392
420INTERFACE INLINE char * 393INTERFACE char *
421symname (pointer p) 394symname (pointer p)
422{ 395{
423 return strvalue (car (p)); 396 return strvalue (car (p));
424} 397}
425 398
426#if USE_PLIST 399#if USE_PLIST
427SCHEME_EXPORT INLINE int 400SCHEME_EXPORT int
428hasprop (pointer p) 401hasprop (pointer p)
429{ 402{
430 return typeflag (p) & T_SYMBOL; 403 return typeflag (p) & T_SYMBOL;
431} 404}
432 405
433# define symprop(p) cdr(p) 406# define symprop(p) cdr(p)
434#endif 407#endif
435 408
436INTERFACE INLINE int 409INTERFACE int
437is_syntax (pointer p) 410is_syntax (pointer p)
438{ 411{
439 return typeflag (p) & T_SYNTAX; 412 return typeflag (p) & T_SYNTAX;
440} 413}
441 414
442INTERFACE INLINE int 415INTERFACE int
443is_proc (pointer p) 416is_proc (pointer p)
444{ 417{
445 return type (p) == T_PROC; 418 return type (p) == T_PROC;
446} 419}
447 420
448INTERFACE INLINE int 421INTERFACE int
449is_foreign (pointer p) 422is_foreign (pointer p)
450{ 423{
451 return type (p) == T_FOREIGN; 424 return type (p) == T_FOREIGN;
452} 425}
453 426
454INTERFACE INLINE char * 427INTERFACE char *
455syntaxname (pointer p) 428syntaxname (pointer p)
456{ 429{
457 return strvalue (car (p)); 430 return strvalue (car (p));
458} 431}
459 432
460#define procnum(p) ivalue (p) 433#define procnum(p) ivalue_unchecked (p)
461static const char *procname (pointer x); 434static const char *procname (pointer x);
462 435
463INTERFACE INLINE int 436INTERFACE int
464is_closure (pointer p) 437is_closure (pointer p)
465{ 438{
466 return type (p) == T_CLOSURE; 439 return type (p) == T_CLOSURE;
467} 440}
468 441
469INTERFACE INLINE int 442INTERFACE int
470is_macro (pointer p) 443is_macro (pointer p)
471{ 444{
472 return type (p) == T_MACRO; 445 return type (p) == T_MACRO;
473} 446}
474 447
475INTERFACE INLINE pointer 448INTERFACE pointer
476closure_code (pointer p) 449closure_code (pointer p)
477{ 450{
478 return car (p); 451 return car (p);
479} 452}
480 453
481INTERFACE INLINE pointer 454INTERFACE pointer
482closure_env (pointer p) 455closure_env (pointer p)
483{ 456{
484 return cdr (p); 457 return cdr (p);
485} 458}
486 459
487INTERFACE INLINE int 460INTERFACE int
488is_continuation (pointer p) 461is_continuation (pointer p)
489{ 462{
490 return type (p) == T_CONTINUATION; 463 return type (p) == T_CONTINUATION;
491} 464}
492 465
493#define cont_dump(p) cdr (p) 466#define cont_dump(p) cdr (p)
494#define set_cont_dump(p,v) set_cdr ((p), (v)) 467#define set_cont_dump(p,v) set_cdr ((p), (v))
495 468
496/* To do: promise should be forced ONCE only */ 469/* To do: promise should be forced ONCE only */
497INTERFACE INLINE int 470INTERFACE int
498is_promise (pointer p) 471is_promise (pointer p)
499{ 472{
500 return type (p) == T_PROMISE; 473 return type (p) == T_PROMISE;
501} 474}
502 475
503INTERFACE INLINE int 476INTERFACE int
504is_environment (pointer p) 477is_environment (pointer p)
505{ 478{
506 return type (p) == T_ENVIRONMENT; 479 return type (p) == T_ENVIRONMENT;
507} 480}
508 481
… …
514 487
515#define is_mark(p) (typeflag (p) & T_MARK) 488#define is_mark(p) (typeflag (p) & T_MARK)
516#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 489#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
517#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 490#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518 491
519INTERFACE INLINE int 492INTERFACE int
520is_immutable (pointer p) 493is_immutable (pointer p)
521{ 494{
522 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 495 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523} 496}
524 497
525INTERFACE INLINE void 498INTERFACE void
526setimmutable (pointer p) 499setimmutable (pointer p)
527{ 500{
528#if USE_ERROR_CHECKING 501#if USE_ERROR_CHECKING
529 set_typeflag (p, typeflag (p) | T_IMMUTABLE); 502 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
530#endif 503#endif
531} 504}
532 505
506/* Result is:
507 proper list: length
508 circular list: -1
509 not even a pair: -2
510 dotted list: -2 minus length before dot
511*/
512INTERFACE int
513list_length (SCHEME_P_ pointer a)
514{
515 int i = 0;
516 pointer slow, fast;
517
518 slow = fast = a;
519
520 while (1)
521 {
522 if (fast == NIL)
523 return i;
524
525 if (!is_pair (fast))
526 return -2 - i;
527
528 fast = cdr (fast);
529 ++i;
530
531 if (fast == NIL)
532 return i;
533
534 if (!is_pair (fast))
535 return -2 - i;
536
537 ++i;
538 fast = cdr (fast);
539
540 /* Safe because we would have already returned if `fast'
541 encountered a non-pair. */
542 slow = cdr (slow);
543
544 if (fast == slow)
545 {
546 /* the fast pointer has looped back around and caught up
547 with the slow pointer, hence the structure is circular,
548 not of finite length, and therefore not a list */
549 return -1;
550 }
551 }
552}
553
554INTERFACE int
555is_list (SCHEME_P_ pointer a)
556{
557 return list_length (SCHEME_A_ a) >= 0;
558}
559
533#if USE_CHAR_CLASSIFIERS 560#if USE_CHAR_CLASSIFIERS
534static INLINE int 561ecb_inline int
535Cisalpha (int c) 562Cisalpha (int c)
536{ 563{
537 return isascii (c) && isalpha (c); 564 return isascii (c) && isalpha (c);
538} 565}
539 566
540static INLINE int 567ecb_inline int
541Cisdigit (int c) 568Cisdigit (int c)
542{ 569{
543 return isascii (c) && isdigit (c); 570 return isascii (c) && isdigit (c);
544} 571}
545 572
546static INLINE int 573ecb_inline int
547Cisspace (int c) 574Cisspace (int c)
548{ 575{
549 return isascii (c) && isspace (c); 576 return isascii (c) && isspace (c);
550} 577}
551 578
552static INLINE int 579ecb_inline int
553Cisupper (int c) 580Cisupper (int c)
554{ 581{
555 return isascii (c) && isupper (c); 582 return isascii (c) && isupper (c);
556} 583}
557 584
558static INLINE int 585ecb_inline int
559Cislower (int c) 586Cislower (int c)
560{ 587{
561 return isascii (c) && islower (c); 588 return isascii (c) && islower (c);
562} 589}
563#endif 590#endif
… …
624#endif 651#endif
625 652
626static int file_push (SCHEME_P_ const char *fname); 653static int file_push (SCHEME_P_ const char *fname);
627static void file_pop (SCHEME_P); 654static void file_pop (SCHEME_P);
628static int file_interactive (SCHEME_P); 655static int file_interactive (SCHEME_P);
629static INLINE int is_one_of (char *s, int c); 656ecb_inline int is_one_of (char *s, int c);
630static int alloc_cellseg (SCHEME_P_ int n); 657static int alloc_cellseg (SCHEME_P_ int n);
631static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 658ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632static void finalize_cell (SCHEME_P_ pointer a); 659static void finalize_cell (SCHEME_P_ pointer a);
633static int count_consecutive_cells (pointer x, int needed); 660static int count_consecutive_cells (pointer x, int needed);
634static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 661static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
635static pointer mk_number (SCHEME_P_ const num n); 662static pointer mk_number (SCHEME_P_ const num n);
636static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 663static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
… …
653static int basic_inchar (port *pt); 680static int basic_inchar (port *pt);
654static int inchar (SCHEME_P); 681static int inchar (SCHEME_P);
655static void backchar (SCHEME_P_ int c); 682static void backchar (SCHEME_P_ int c);
656static char *readstr_upto (SCHEME_P_ char *delim); 683static char *readstr_upto (SCHEME_P_ char *delim);
657static pointer readstrexp (SCHEME_P); 684static pointer readstrexp (SCHEME_P);
658static INLINE int skipspace (SCHEME_P); 685ecb_inline int skipspace (SCHEME_P);
659static int token (SCHEME_P); 686static int token (SCHEME_P);
660static void printslashstring (SCHEME_P_ char *s, int len); 687static void printslashstring (SCHEME_P_ char *s, int len);
661static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 688static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
662static void printatom (SCHEME_P_ pointer l, int f); 689static void printatom (SCHEME_P_ pointer l, int f);
663static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 690static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
667static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); 694static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
668static pointer revappend (SCHEME_P_ pointer a, pointer b); 695static pointer revappend (SCHEME_P_ pointer a, pointer b);
669static pointer ss_get_cont (SCHEME_P); 696static pointer ss_get_cont (SCHEME_P);
670static void ss_set_cont (SCHEME_P_ pointer cont); 697static void ss_set_cont (SCHEME_P_ pointer cont);
671static void dump_stack_mark (SCHEME_P); 698static void dump_stack_mark (SCHEME_P);
672static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 699static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
700static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
673static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); 701static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
674static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
675static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 702static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
676static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 703static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
677static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 704static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
678static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 705static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
679static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 706static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
680static void assign_syntax (SCHEME_P_ const char *name); 707static void assign_syntax (SCHEME_P_ const char *name);
681static int syntaxnum (pointer p); 708static int syntaxnum (pointer p);
682static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 709static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
683 710
711static IVALUE
712ivalue (pointer x)
713{
714 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
715}
716
717static RVALUE
718rvalue (pointer x)
719{
720 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
721}
722
723INTERFACE num
724nvalue (pointer x)
725{
726 num n;
727
728 num_set_fixnum (n, is_integer (x));
729
730 if (num_is_fixnum (n))
731 num_set_ivalue (n, ivalue_unchecked (x));
732 else
733 num_set_rvalue (n, rvalue_unchecked (x));
734
735 return n;
736}
737
684static num 738static num
685num_op (enum num_op op, num a, num b) 739num_op (enum num_op op, num a, num b)
686{ 740{
687 num ret; 741 num ret;
688 742
689 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 743 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
690 744
691 if (num_is_fixnum (ret)) 745 if (num_is_fixnum (ret))
692 { 746 {
693 IVALUE av = num_get_ivalue (a);
694 IVALUE bv = num_get_ivalue (b);
695
696 switch (op) 747 switch (op)
697 { 748 {
698 case NUM_ADD: av += bv; break; 749 case NUM_ADD: a.ivalue += b.ivalue; break;
699 case NUM_SUB: av -= bv; break; 750 case NUM_SUB: a.ivalue -= b.ivalue; break;
700 case NUM_MUL: av *= bv; break; 751 case NUM_MUL: a.ivalue *= b.ivalue; break;
701 case NUM_INTDIV: av /= bv; break; 752 case NUM_INTDIV: a.ivalue /= b.ivalue; break;
702 } 753 }
703 754
704 num_set_ivalue (ret, av); 755 num_set_ivalue (ret, a.ivalue);
705 } 756 }
757#if USE_REAL
706 else 758 else
707 { 759 {
708 RVALUE av = num_get_rvalue (a);
709 RVALUE bv = num_get_rvalue (b);
710
711 switch (op) 760 switch (op)
712 { 761 {
713 case NUM_ADD: av += bv; break; 762 case NUM_ADD: a.rvalue += b.rvalue; break;
714 case NUM_SUB: av -= bv; break; 763 case NUM_SUB: a.rvalue -= b.rvalue; break;
715 case NUM_MUL: av *= bv; break; 764 case NUM_MUL: a.rvalue *= b.rvalue; break;
716 case NUM_INTDIV: av /= bv; break; 765 case NUM_INTDIV: a.rvalue /= b.rvalue; break;
717 } 766 }
718 767
719 num_set_rvalue (ret, av); 768 num_set_rvalue (ret, a.rvalue);
720 } 769 }
770#endif
721 771
722 return ret; 772 return ret;
723} 773}
724 774
725static num 775static num
726num_div (num a, num b) 776num_div (num a, num b)
727{ 777{
728 num ret; 778 num ret;
729 779
730 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); 780 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
731 781
732 if (num_is_fixnum (ret)) 782 if (num_is_fixnum (ret))
733 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); 783 num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
734 else 784 else
735 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); 785 num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
736 786
737 return ret; 787 return ret;
738} 788}
739 789
740static num 790static num
… …
742{ 792{
743 num ret; 793 num ret;
744 long e1, e2, res; 794 long e1, e2, res;
745 795
746 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 796 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
747 e1 = num_get_ivalue (a); 797 e1 = num_ivalue (a);
748 e2 = num_get_ivalue (b); 798 e2 = num_ivalue (b);
749 res = e1 % e2; 799 res = e1 % e2;
750 800
751 /* remainder should have same sign as second operand */ 801 /* remainder should have same sign as second operand */
752 if (res > 0) 802 if (res > 0)
753 { 803 {
… …
769{ 819{
770 num ret; 820 num ret;
771 long e1, e2, res; 821 long e1, e2, res;
772 822
773 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 823 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
774 e1 = num_get_ivalue (a); 824 e1 = num_ivalue (a);
775 e2 = num_get_ivalue (b); 825 e2 = num_ivalue (b);
776 res = e1 % e2; 826 res = e1 % e2;
777 827
778 /* modulo should have same sign as second operand */ 828 /* modulo should have same sign as second operand */
779 if (res * e2 < 0) 829 if (res * e2 < 0)
780 res += e2; 830 res += e2;
781 831
782 num_set_ivalue (ret, res); 832 num_set_ivalue (ret, res);
783 return ret; 833 return ret;
784} 834}
785 835
786/* this completely disrespects NaNs */ 836/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787static int 837static int
788num_cmp (num a, num b) 838num_cmp (num a, num b)
789{ 839{
790 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 840 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791 int ret; 841 int ret;
792 842
793 if (is_fixnum) 843 if (is_fixnum)
794 { 844 {
795 IVALUE av = num_get_ivalue (a); 845 IVALUE av = num_ivalue (a);
796 IVALUE bv = num_get_ivalue (b); 846 IVALUE bv = num_ivalue (b);
797 847
798 ret = av == bv ? 0 : av < bv ? -1 : +1; 848 ret = av == bv ? 0 : av < bv ? -1 : +1;
799 } 849 }
800 else 850 else
801 { 851 {
802 RVALUE av = num_get_rvalue (a); 852 RVALUE av = num_rvalue (a);
803 RVALUE bv = num_get_rvalue (b); 853 RVALUE bv = num_rvalue (b);
804 854
805 ret = av == bv ? 0 : av < bv ? -1 : +1; 855 ret = av == bv ? 0 : av < bv ? -1 : +1;
806 } 856 }
807 857
808 return ret; 858 return ret;
… …
834#endif 884#endif
835 885
836static int 886static int
837is_zero_rvalue (RVALUE x) 887is_zero_rvalue (RVALUE x)
838{ 888{
889 return x == 0;
890#if 0
839#if USE_REAL 891#if USE_REAL
840 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 892 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
841#else 893#else
842 return x == 0; 894 return x == 0;
895#endif
843#endif 896#endif
844} 897}
845 898
846/* allocate new cell segment */ 899/* allocate new cell segment */
847static int 900static int
… …
868 return k; 921 return k;
869 922
870 i = ++SCHEME_V->last_cell_seg; 923 i = ++SCHEME_V->last_cell_seg;
871 SCHEME_V->alloc_seg[i] = cp; 924 SCHEME_V->alloc_seg[i] = cp;
872 925
873 /* insert new segment in address order */
874 newp = (pointer)cp; 926 newp = (pointer)cp;
875 SCHEME_V->cell_seg[i] = newp; 927 SCHEME_V->cell_seg[i] = newp;
876 SCHEME_V->cell_segsize[i] = segsize; 928 SCHEME_V->cell_segsize[i] = segsize;
877
878 //TODO: insert, not swap
879 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
880 {
881 p = SCHEME_V->cell_seg[i];
882 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
883 SCHEME_V->cell_seg[i - 1] = p;
884
885 k = SCHEME_V->cell_segsize[i];
886 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
887 SCHEME_V->cell_segsize[i - 1] = k;
888
889 --i;
890 }
891
892 SCHEME_V->fcells += segsize; 929 SCHEME_V->fcells += segsize;
893 last = newp + segsize - 1; 930 last = newp + segsize - 1;
894 931
895 for (p = newp; p <= last; p++) 932 for (p = newp; p <= last; p++)
896 { 933 {
897 set_typeflag (p, T_FREE); 934 set_typeflag (p, T_PAIR);
898 set_car (p, NIL); 935 set_car (p, NIL);
899 set_cdr (p, p + 1); 936 set_cdr (p, p + 1);
900 } 937 }
901 938
902 /* insert new cells in address order on free list */
903 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
904 {
905 set_cdr (last, SCHEME_V->free_cell); 939 set_cdr (last, SCHEME_V->free_cell);
906 SCHEME_V->free_cell = newp; 940 SCHEME_V->free_cell = newp;
907 }
908 else
909 {
910 p = SCHEME_V->free_cell;
911
912 while (cdr (p) != NIL && newp > cdr (p))
913 p = cdr (p);
914
915 set_cdr (last, cdr (p));
916 set_cdr (p, newp);
917 }
918 } 941 }
919 942
920 return n; 943 return n;
921} 944}
922 945
923/* get new cell. parameter a, b is marked by gc. */ 946/* get new cell. parameter a, b is marked by gc. */
924static INLINE pointer 947ecb_inline pointer
925get_cell_x (SCHEME_P_ pointer a, pointer b) 948get_cell_x (SCHEME_P_ pointer a, pointer b)
926{ 949{
927 if (ecb_expect_false (SCHEME_V->free_cell == NIL)) 950 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928 { 951 {
929 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 952 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
… …
1001 /* Record it as a vector so that gc understands it. */ 1024 /* Record it as a vector so that gc understands it. */
1002 set_typeflag (v, T_VECTOR | T_ATOM); 1025 set_typeflag (v, T_VECTOR | T_ATOM);
1003 1026
1004 v->object.vector.vvalue = e; 1027 v->object.vector.vvalue = e;
1005 v->object.vector.length = len; 1028 v->object.vector.length = len;
1006 fill_vector (v, init); 1029 fill_vector (v, 0, init);
1007 push_recent_alloc (SCHEME_A_ v, NIL); 1030 push_recent_alloc (SCHEME_A_ v, NIL);
1008 1031
1009 return v; 1032 return v;
1010} 1033}
1011 1034
1012static INLINE void 1035ecb_inline void
1013ok_to_freely_gc (SCHEME_P) 1036ok_to_freely_gc (SCHEME_P)
1014{ 1037{
1015 set_car (S_SINK, NIL); 1038 set_car (S_SINK, NIL);
1016} 1039}
1017 1040
… …
1077 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1100 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1078 set_typeflag (x, T_SYMBOL); 1101 set_typeflag (x, T_SYMBOL);
1079 setimmutable (car (x)); 1102 setimmutable (car (x));
1080 1103
1081 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1104 location = hash_fn (name, veclength (SCHEME_V->oblist));
1082 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1105 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1083 return x; 1106 return x;
1084} 1107}
1085 1108
1086static INLINE pointer 1109ecb_inline pointer
1087oblist_find_by_name (SCHEME_P_ const char *name) 1110oblist_find_by_name (SCHEME_P_ const char *name)
1088{ 1111{
1089 int location; 1112 int location;
1090 pointer x; 1113 pointer x;
1091 char *s; 1114 char *s;
1092 1115
1093 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1116 location = hash_fn (name, veclength (SCHEME_V->oblist));
1094 1117
1095 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1118 for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1096 { 1119 {
1097 s = symname (car (x)); 1120 s = symname (car (x));
1098 1121
1099 /* case-insensitive, per R5RS section 2 */ 1122 /* case-insensitive, per R5RS section 2 */
1100 if (stricmp (name, s) == 0) 1123 if (stricmp (name, s) == 0)
… …
1110 int i; 1133 int i;
1111 pointer x; 1134 pointer x;
1112 pointer ob_list = NIL; 1135 pointer ob_list = NIL;
1113 1136
1114 for (i = 0; i < veclength (SCHEME_V->oblist); i++) 1137 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1115 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1138 for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1116 ob_list = cons (x, ob_list); 1139 ob_list = cons (x, ob_list);
1117 1140
1118 return ob_list; 1141 return ob_list;
1119} 1142}
1120 1143
… …
1124oblist_initial_value (SCHEME_P) 1147oblist_initial_value (SCHEME_P)
1125{ 1148{
1126 return NIL; 1149 return NIL;
1127} 1150}
1128 1151
1129static INLINE pointer 1152ecb_inline pointer
1130oblist_find_by_name (SCHEME_P_ const char *name) 1153oblist_find_by_name (SCHEME_P_ const char *name)
1131{ 1154{
1132 pointer x; 1155 pointer x;
1133 char *s; 1156 char *s;
1134 1157
… …
1193mk_character (SCHEME_P_ int c) 1216mk_character (SCHEME_P_ int c)
1194{ 1217{
1195 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1218 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1196 1219
1197 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1220 set_typeflag (x, (T_CHARACTER | T_ATOM));
1198 ivalue_unchecked (x) = c & 0xff; 1221 set_ivalue (x, c & 0xff);
1199 set_num_integer (x); 1222
1200 return x; 1223 return x;
1201} 1224}
1202 1225
1203/* get number atom (integer) */ 1226/* get number atom (integer) */
1204INTERFACE pointer 1227INTERFACE pointer
1205mk_integer (SCHEME_P_ long num) 1228mk_integer (SCHEME_P_ long n)
1206{ 1229{
1207 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1230 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1208 1231
1209 set_typeflag (x, (T_NUMBER | T_ATOM)); 1232 set_typeflag (x, (T_INTEGER | T_ATOM));
1210 ivalue_unchecked (x) = num; 1233 set_ivalue (x, n);
1211 set_num_integer (x); 1234
1212 return x; 1235 return x;
1213} 1236}
1214 1237
1215INTERFACE pointer 1238INTERFACE pointer
1216mk_real (SCHEME_P_ RVALUE n) 1239mk_real (SCHEME_P_ RVALUE n)
1217{ 1240{
1241#if USE_REAL
1218 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1242 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1219 1243
1220 set_typeflag (x, (T_NUMBER | T_ATOM)); 1244 set_typeflag (x, (T_REAL | T_ATOM));
1221 rvalue_unchecked (x) = n; 1245 set_rvalue (x, n);
1222 set_num_real (x); 1246
1223 return x; 1247 return x;
1248#else
1249 return mk_integer (SCHEME_A_ n);
1250#endif
1224} 1251}
1225 1252
1226static pointer 1253static pointer
1227mk_number (SCHEME_P_ const num n) 1254mk_number (SCHEME_P_ const num n)
1228{ 1255{
1256#if USE_REAL
1229 if (num_is_fixnum (n)) 1257 return num_is_fixnum (n)
1258 ? mk_integer (SCHEME_A_ num_ivalue (n))
1259 : mk_real (SCHEME_A_ num_rvalue (n));
1260#else
1230 return mk_integer (SCHEME_A_ num_get_ivalue (n)); 1261 return mk_integer (SCHEME_A_ num_ivalue (n));
1231 else 1262#endif
1232 return mk_real (SCHEME_A_ num_get_rvalue (n));
1233} 1263}
1234 1264
1235/* allocate name to string area */ 1265/* allocate name to string area */
1236static char * 1266static char *
1237store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill) 1267store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
… …
1296{ 1326{
1297 return get_vector_object (SCHEME_A_ len, NIL); 1327 return get_vector_object (SCHEME_A_ len, NIL);
1298} 1328}
1299 1329
1300INTERFACE void 1330INTERFACE void
1301fill_vector (pointer vec, pointer obj) 1331fill_vector (pointer vec, uint32_t start, pointer obj)
1302{ 1332{
1303 int i; 1333 int i;
1304 1334
1305 for (i = 0; i < vec->object.vector.length; i++) 1335 for (i = start; i < veclength (vec); i++)
1306 vecvalue (vec)[i] = obj; 1336 vecvalue (vec)[i] = obj;
1307} 1337}
1308 1338
1309INTERFACE pointer 1339INTERFACE pointer
1310vector_elem (pointer vec, uint32_t ielem) 1340vector_get (pointer vec, uint32_t ielem)
1311{ 1341{
1312 return vecvalue(vec)[ielem]; 1342 return vecvalue(vec)[ielem];
1313} 1343}
1314 1344
1315INTERFACE void 1345INTERFACE void
1316set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1346vector_set (pointer vec, uint32_t ielem, pointer a)
1317{ 1347{
1318 vecvalue(vec)[ielem] = a; 1348 vecvalue(vec)[ielem] = a;
1319} 1349}
1320 1350
1321/* get new symbol */ 1351/* get new symbol */
… …
1413 } 1443 }
1414 else if ((c == 'e') || (c == 'E')) 1444 else if ((c == 'e') || (c == 'E'))
1415 { 1445 {
1416 if (!has_fp_exp) 1446 if (!has_fp_exp)
1417 { 1447 {
1418 has_dec_point = 1; /* decimal point illegal 1448 has_dec_point = 1; /* decimal point illegal from now on */
1419 from now on */
1420 p++; 1449 p++;
1421 1450
1422 if ((*p == '-') || (*p == '+') || isdigit (*p)) 1451 if ((*p == '-') || (*p == '+') || isdigit (*p))
1423 continue; 1452 continue;
1424 } 1453 }
… …
1512 1541
1513 if (ecb_expect_false (is_vector (p))) 1542 if (ecb_expect_false (is_vector (p)))
1514 { 1543 {
1515 int i; 1544 int i;
1516 1545
1517 for (i = 0; i < p->object.vector.length; i++) 1546 for (i = 0; i < veclength (p); i++)
1518 mark (vecvalue (p)[i]); 1547 mark (vecvalue (p)[i]);
1519 } 1548 }
1520 1549
1521 if (is_atom (p)) 1550 if (is_atom (p))
1522 goto E6; 1551 goto E6;
… …
1620 if (is_mark (p)) 1649 if (is_mark (p))
1621 clrmark (p); 1650 clrmark (p);
1622 else 1651 else
1623 { 1652 {
1624 /* reclaim cell */ 1653 /* reclaim cell */
1625 if (typeflag (p) != T_FREE) 1654 if (typeflag (p) != T_PAIR)
1626 { 1655 {
1627 finalize_cell (SCHEME_A_ p); 1656 finalize_cell (SCHEME_A_ p);
1628 set_typeflag (p, T_FREE); 1657 set_typeflag (p, T_PAIR);
1629 set_car (p, NIL); 1658 set_car (p, NIL);
1630 } 1659 }
1631 1660
1632 ++SCHEME_V->fcells; 1661 ++SCHEME_V->fcells;
1633 set_cdr (p, SCHEME_V->free_cell); 1662 set_cdr (p, SCHEME_V->free_cell);
… …
1635 } 1664 }
1636 } 1665 }
1637 } 1666 }
1638 1667
1639 if (SCHEME_V->gc_verbose) 1668 if (SCHEME_V->gc_verbose)
1669 {
1640 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1670 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
1671 }
1641} 1672}
1642 1673
1643static void 1674static void
1644finalize_cell (SCHEME_P_ pointer a) 1675finalize_cell (SCHEME_P_ pointer a)
1645{ 1676{
… …
2232 } 2263 }
2233 } 2264 }
2234} 2265}
2235 2266
2236/* check c is in chars */ 2267/* check c is in chars */
2237static INLINE int 2268ecb_inline int
2238is_one_of (char *s, int c) 2269is_one_of (char *s, int c)
2239{ 2270{
2240 if (c == EOF) 2271 if (c == EOF)
2241 return 1; 2272 return 1;
2242 2273
2243 return !!strchr (s, c); 2274 return !!strchr (s, c);
2244} 2275}
2245 2276
2246/* skip white characters */ 2277/* skip white characters */
2247static INLINE int 2278ecb_inline int
2248skipspace (SCHEME_P) 2279skipspace (SCHEME_P)
2249{ 2280{
2250 int c, curr_line = 0; 2281 int c, curr_line = 0;
2251 2282
2252 do 2283 do
… …
2480 { 2511 {
2481 p = SCHEME_V->strbuff; 2512 p = SCHEME_V->strbuff;
2482 2513
2483 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2514 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2484 { 2515 {
2485 if (num_is_integer (l)) 2516 if (is_integer (l))
2486 xnum (p, ivalue_unchecked (l)); 2517 xnum (p, ivalue_unchecked (l));
2487#if USE_REAL 2518#if USE_REAL
2488 else 2519 else
2489 { 2520 {
2490 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2521 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
… …
2745 return 0; 2776 return 0;
2746 } 2777 }
2747 else if (is_number (a)) 2778 else if (is_number (a))
2748 { 2779 {
2749 if (is_number (b)) 2780 if (is_number (b))
2750 if (num_is_integer (a) == num_is_integer (b))
2751 return num_cmp (nvalue (a), nvalue (b)) == 0; 2781 return num_cmp (nvalue (a), nvalue (b)) == 0;
2752 2782
2753 return 0; 2783 return 0;
2754 } 2784 }
2755 else if (is_character (a)) 2785 else if (is_character (a))
2756 { 2786 {
… …
2823 2853
2824 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2854 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825 setenvironment (SCHEME_V->envir); 2855 setenvironment (SCHEME_V->envir);
2826} 2856}
2827 2857
2828static INLINE void 2858ecb_inline void
2829new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2859new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830{ 2860{
2831 pointer slot = immutable_cons (variable, value); 2861 pointer slot = immutable_cons (variable, value);
2832 2862
2833 if (is_vector (car (env))) 2863 if (is_vector (car (env)))
2834 { 2864 {
2835 int location = hash_fn (symname (variable), veclength (car (env))); 2865 int location = hash_fn (symname (variable), veclength (car (env)));
2836 2866
2837 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2867 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2838 } 2868 }
2839 else 2869 else
2840 set_car (env, immutable_cons (slot, car (env))); 2870 set_car (env, immutable_cons (slot, car (env)));
2841} 2871}
2842 2872
… …
2849 for (x = env; x != NIL; x = cdr (x)) 2879 for (x = env; x != NIL; x = cdr (x))
2850 { 2880 {
2851 if (is_vector (car (x))) 2881 if (is_vector (car (x)))
2852 { 2882 {
2853 location = hash_fn (symname (hdl), veclength (car (x))); 2883 location = hash_fn (symname (hdl), veclength (car (x)));
2854 y = vector_elem (car (x), location); 2884 y = vector_get (car (x), location);
2855 } 2885 }
2856 else 2886 else
2857 y = car (x); 2887 y = car (x);
2858 2888
2859 for (; y != NIL; y = cdr (y)) 2889 for (; y != NIL; y = cdr (y))
2860 if (caar (y) == hdl) 2890 if (caar (y) == hdl)
2861 break; 2891 break;
2862 2892
2863 if (y != NIL) 2893 if (y != NIL)
2894 return car (y);
2895
2896 if (!all)
2864 break; 2897 break;
2865
2866 if (!all)
2867 return NIL;
2868 } 2898 }
2869
2870 if (x != NIL)
2871 return car (y);
2872 2899
2873 return NIL; 2900 return NIL;
2874} 2901}
2875 2902
2876#else /* USE_ALIST_ENV */ 2903#else /* USE_ALIST_ENV */
2877 2904
2878static INLINE void 2905ecb_inline void
2879new_frame_in_env (SCHEME_P_ pointer old_env) 2906new_frame_in_env (SCHEME_P_ pointer old_env)
2880{ 2907{
2881 SCHEME_V->envir = immutable_cons (NIL, old_env); 2908 SCHEME_V->envir = immutable_cons (NIL, old_env);
2882 setenvironment (SCHEME_V->envir); 2909 setenvironment (SCHEME_V->envir);
2883} 2910}
2884 2911
2885static INLINE void 2912ecb_inline void
2886new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2913new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887{ 2914{
2888 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2915 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889} 2916}
2890 2917
… …
2912 return NIL; 2939 return NIL;
2913} 2940}
2914 2941
2915#endif /* USE_ALIST_ENV else */ 2942#endif /* USE_ALIST_ENV else */
2916 2943
2917static INLINE void 2944ecb_inline void
2918new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2945new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919{ 2946{
2920 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2947 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921} 2948}
2922 2949
2923static INLINE void 2950ecb_inline void
2924set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2951set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925{ 2952{
2926 set_cdr (slot, value); 2953 set_cdr (slot, value);
2927} 2954}
2928 2955
2929static INLINE pointer 2956ecb_inline pointer
2930slot_value_in_env (pointer slot) 2957slot_value_in_env (pointer slot)
2931{ 2958{
2932 return cdr (slot); 2959 return cdr (slot);
2933} 2960}
2934 2961
2935/* ========== Evaluation Cycle ========== */ 2962/* ========== Evaluation Cycle ========== */
2936 2963
2937static pointer 2964static int
2938xError_1 (SCHEME_P_ const char *s, pointer a) 2965xError_1 (SCHEME_P_ const char *s, pointer a)
2939{ 2966{
2940#if USE_ERROR_HOOK 2967#if USE_ERROR_HOOK
2941 pointer x; 2968 pointer x;
2942 pointer hdl = SCHEME_V->ERROR_HOOK; 2969 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
2977 code = cons (mk_string (SCHEME_A_ s), code); 3004 code = cons (mk_string (SCHEME_A_ s), code);
2978 setimmutable (car (code)); 3005 setimmutable (car (code));
2979 SCHEME_V->code = cons (slot_value_in_env (x), code); 3006 SCHEME_V->code = cons (slot_value_in_env (x), code);
2980 SCHEME_V->op = OP_EVAL; 3007 SCHEME_V->op = OP_EVAL;
2981 3008
2982 return S_T; 3009 return 0;
2983 } 3010 }
2984#endif 3011#endif
2985 3012
2986 if (a) 3013 if (a)
2987 SCHEME_V->args = cons (a, NIL); 3014 SCHEME_V->args = cons (a, NIL);
… …
2989 SCHEME_V->args = NIL; 3016 SCHEME_V->args = NIL;
2990 3017
2991 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); 3018 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2992 setimmutable (car (SCHEME_V->args)); 3019 setimmutable (car (SCHEME_V->args));
2993 SCHEME_V->op = OP_ERR0; 3020 SCHEME_V->op = OP_ERR0;
3021
2994 return S_T; 3022 return 0;
2995} 3023}
2996 3024
2997#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) 3025#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2998#define Error_0(s) Error_1 (s, 0) 3026#define Error_0(s) Error_1 (s, 0)
2999 3027
3000/* Too small to turn into function */ 3028/* Too small to turn into function */
3001#define BEGIN do { 3029#define BEGIN do {
3002#define END } while (0) 3030#define END } while (0)
3003#define s_goto(a) BEGIN \ 3031#define s_goto(a) BEGIN \
3004 SCHEME_V->op = a; \ 3032 SCHEME_V->op = a; \
3005 return S_T; END 3033 return 0; END
3006 3034
3007#define s_return(a) return xs_return (SCHEME_A_ a) 3035#define s_return(a) return xs_return (SCHEME_A_ a)
3008 3036
3009#ifndef USE_SCHEME_STACK 3037#ifndef USE_SCHEME_STACK
3010 3038
… …
3040 next_frame->code = code; 3068 next_frame->code = code;
3041 3069
3042 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3070 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3043} 3071}
3044 3072
3045static pointer 3073static int
3046xs_return (SCHEME_P_ pointer a) 3074xs_return (SCHEME_P_ pointer a)
3047{ 3075{
3048 int nframes = (uintptr_t)SCHEME_V->dump; 3076 int nframes = (uintptr_t)SCHEME_V->dump;
3049 struct dump_stack_frame *frame; 3077 struct dump_stack_frame *frame;
3050 3078
3051 SCHEME_V->value = a; 3079 SCHEME_V->value = a;
3052 3080
3053 if (nframes <= 0) 3081 if (nframes <= 0)
3054 return NIL; 3082 return -1;
3055 3083
3056 frame = &SCHEME_V->dump_base[--nframes]; 3084 frame = &SCHEME_V->dump_base[--nframes];
3057 SCHEME_V->op = frame->op; 3085 SCHEME_V->op = frame->op;
3058 SCHEME_V->args = frame->args; 3086 SCHEME_V->args = frame->args;
3059 SCHEME_V->envir = frame->envir; 3087 SCHEME_V->envir = frame->envir;
3060 SCHEME_V->code = frame->code; 3088 SCHEME_V->code = frame->code;
3061 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3089 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3062 3090
3063 return S_T; 3091 return 0;
3064} 3092}
3065 3093
3066static INLINE void 3094ecb_inline void
3067dump_stack_reset (SCHEME_P) 3095dump_stack_reset (SCHEME_P)
3068{ 3096{
3069 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3097 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3070 SCHEME_V->dump = (pointer)+0; 3098 SCHEME_V->dump = (pointer)+0;
3071} 3099}
3072 3100
3073static INLINE void 3101ecb_inline void
3074dump_stack_initialize (SCHEME_P) 3102dump_stack_initialize (SCHEME_P)
3075{ 3103{
3076 SCHEME_V->dump_size = 0; 3104 SCHEME_V->dump_size = 0;
3077 SCHEME_V->dump_base = 0; 3105 SCHEME_V->dump_base = 0;
3078 dump_stack_reset (SCHEME_A); 3106 dump_stack_reset (SCHEME_A);
… …
3131 int i = 0; 3159 int i = 0;
3132 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3160 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3133 3161
3134 while (cont != NIL) 3162 while (cont != NIL)
3135 { 3163 {
3136 frame->op = ivalue (car (cont)); cont = cdr (cont); 3164 frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3137 frame->args = car (cont) ; cont = cdr (cont); 3165 frame->args = car (cont) ; cont = cdr (cont);
3138 frame->envir = car (cont) ; cont = cdr (cont); 3166 frame->envir = car (cont) ; cont = cdr (cont);
3139 frame->code = car (cont) ; cont = cdr (cont); 3167 frame->code = car (cont) ; cont = cdr (cont);
3140 3168
3141 ++frame; 3169 ++frame;
3142 ++i; 3170 ++i;
3143 } 3171 }
3144 3172
3145 SCHEME_V->dump = (pointer)(uintptr_t)i; 3173 SCHEME_V->dump = (pointer)(uintptr_t)i;
3146} 3174}
3147 3175
3148#else 3176#else
3149 3177
3150static INLINE void 3178ecb_inline void
3151dump_stack_reset (SCHEME_P) 3179dump_stack_reset (SCHEME_P)
3152{ 3180{
3153 SCHEME_V->dump = NIL; 3181 SCHEME_V->dump = NIL;
3154} 3182}
3155 3183
3156static INLINE void 3184ecb_inline void
3157dump_stack_initialize (SCHEME_P) 3185dump_stack_initialize (SCHEME_P)
3158{ 3186{
3159 dump_stack_reset (SCHEME_A); 3187 dump_stack_reset (SCHEME_A);
3160} 3188}
3161 3189
… …
3163dump_stack_free (SCHEME_P) 3191dump_stack_free (SCHEME_P)
3164{ 3192{
3165 SCHEME_V->dump = NIL; 3193 SCHEME_V->dump = NIL;
3166} 3194}
3167 3195
3168static pointer 3196static int
3169xs_return (SCHEME_P_ pointer a) 3197xs_return (SCHEME_P_ pointer a)
3170{ 3198{
3171 pointer dump = SCHEME_V->dump; 3199 pointer dump = SCHEME_V->dump;
3172 3200
3173 SCHEME_V->value = a; 3201 SCHEME_V->value = a;
3174 3202
3175 if (dump == NIL) 3203 if (dump == NIL)
3176 return NIL; 3204 return -1;
3177 3205
3178 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); 3206 SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3179 SCHEME_V->args = car (dump) ; dump = cdr (dump); 3207 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3180 SCHEME_V->envir = car (dump) ; dump = cdr (dump); 3208 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3181 SCHEME_V->code = car (dump) ; dump = cdr (dump); 3209 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3182 3210
3183 SCHEME_V->dump = dump; 3211 SCHEME_V->dump = dump;
3184 3212
3185 return S_T; 3213 return 0;
3186} 3214}
3187 3215
3188static void 3216static void
3189s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3217s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3190{ 3218{
… …
3215 3243
3216#endif 3244#endif
3217 3245
3218#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3246#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3219 3247
3220static pointer 3248static int
3221opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3249opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3222{ 3250{
3223 pointer args = SCHEME_V->args; 3251 pointer args = SCHEME_V->args;
3224 pointer x, y; 3252 pointer x, y;
3225 3253
… …
3392 3420
3393 case OP_TRACING: 3421 case OP_TRACING:
3394 { 3422 {
3395 int tr = SCHEME_V->tracing; 3423 int tr = SCHEME_V->tracing;
3396 3424
3397 SCHEME_V->tracing = ivalue (car (args)); 3425 SCHEME_V->tracing = ivalue_unchecked (car (args));
3398 s_return (mk_integer (SCHEME_A_ tr)); 3426 s_return (mk_integer (SCHEME_A_ tr));
3399 } 3427 }
3400 3428
3401#endif 3429#endif
3402 3430
… …
3911 SCHEME_V->code = car (args); 3939 SCHEME_V->code = car (args);
3912 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); 3940 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3913 s_goto (OP_APPLY); 3941 s_goto (OP_APPLY);
3914 } 3942 }
3915 3943
3916 abort (); 3944 if (USE_ERROR_CHECKING) abort ();
3917} 3945}
3918 3946
3919static pointer 3947static int
3920opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3948opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3921{ 3949{
3922 pointer args = SCHEME_V->args; 3950 pointer args = SCHEME_V->args;
3923 pointer x = car (args); 3951 pointer x = car (args);
3924 num v; 3952 num v;
3925 3953
3926#if USE_MATH
3927 RVALUE dd;
3928#endif
3929
3930 switch (op) 3954 switch (op)
3931 { 3955 {
3932#if USE_MATH 3956#if USE_MATH
3933 case OP_INEX2EX: /* inexact->exact */ 3957 case OP_INEX2EX: /* inexact->exact */
3958 {
3934 if (num_is_integer (x)) 3959 if (is_integer (x))
3935 s_return (x); 3960 s_return (x);
3936 else if (modf (rvalue_unchecked (x), &dd) == 0) 3961
3962 RVALUE r = rvalue_unchecked (x);
3963
3964 if (r == (RVALUE)(IVALUE)r)
3937 s_return (mk_integer (SCHEME_A_ ivalue (x))); 3965 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
3938 else 3966 else
3939 Error_1 ("inexact->exact: not integral:", x); 3967 Error_1 ("inexact->exact: not integral:", x);
3968 }
3940 3969
3941 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 3970 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3942 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 3971 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));
3943 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 3972 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3944 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 3973 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
… …
3962 { 3991 {
3963 RVALUE result; 3992 RVALUE result;
3964 int real_result = 1; 3993 int real_result = 1;
3965 pointer y = cadr (args); 3994 pointer y = cadr (args);
3966 3995
3967 if (num_is_integer (x) && num_is_integer (y)) 3996 if (is_integer (x) && is_integer (y))
3968 real_result = 0; 3997 real_result = 0;
3969 3998
3970 /* This 'if' is an R5RS compatibility fix. */ 3999 /* This 'if' is an R5RS compatibility fix. */
3971 /* NOTE: Remove this 'if' fix for R6RS. */ 4000 /* NOTE: Remove this 'if' fix for R6RS. */
3972 if (rvalue (x) == 0 && rvalue (y) < 0) 4001 if (rvalue (x) == 0 && rvalue (y) < 0)
… …
3978 /* If the test fails, result is too big for integer. */ 4007 /* If the test fails, result is too big for integer. */
3979 if (!real_result) 4008 if (!real_result)
3980 { 4009 {
3981 long result_as_long = result; 4010 long result_as_long = result;
3982 4011
3983 if (result != (RVALUE) result_as_long) 4012 if (result != result_as_long)
3984 real_result = 1; 4013 real_result = 1;
3985 } 4014 }
3986 4015
3987 if (real_result) 4016 if (real_result)
3988 s_return (mk_real (SCHEME_A_ result)); 4017 s_return (mk_real (SCHEME_A_ result));
… …
3993 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 4022 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
3994 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); 4023 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3995 4024
3996 case OP_TRUNCATE: 4025 case OP_TRUNCATE:
3997 { 4026 {
3998 RVALUE rvalue_of_x; 4027 RVALUE n = rvalue (x);
3999
4000 rvalue_of_x = rvalue (x);
4001
4002 if (rvalue_of_x > 0)
4003 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); 4028 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4004 else
4005 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4006 } 4029 }
4007 4030
4008 case OP_ROUND: 4031 case OP_ROUND:
4009 if (num_is_integer (x)) 4032 if (is_integer (x))
4010 s_return (x); 4033 s_return (x);
4011 4034
4012 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); 4035 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4013#endif 4036#endif
4014 4037
4015 case OP_ADD: /* + */ 4038 case OP_ADD: /* + */
4016 v = num_zero; 4039 v = num_zero;
4017 4040
4018 for (x = args; x != NIL; x = cdr (x)) 4041 for (x = args; x != NIL; x = cdr (x))
4019 v = num_op ('+', v, nvalue (car (x))); 4042 v = num_op (NUM_ADD, v, nvalue (car (x)));
4020 4043
4021 s_return (mk_number (SCHEME_A_ v)); 4044 s_return (mk_number (SCHEME_A_ v));
4022 4045
4023 case OP_MUL: /* * */ 4046 case OP_MUL: /* * */
4024 v = num_one; 4047 v = num_one;
4025 4048
4026 for (x = args; x != NIL; x = cdr (x)) 4049 for (x = args; x != NIL; x = cdr (x))
4027 v = num_op ('+', v, nvalue (car (x))); 4050 v = num_op (NUM_MUL, v, nvalue (car (x)));
4028 4051
4029 s_return (mk_number (SCHEME_A_ v)); 4052 s_return (mk_number (SCHEME_A_ v));
4030 4053
4031 case OP_SUB: /* - */ 4054 case OP_SUB: /* - */
4032 if (cdr (args) == NIL) 4055 if (cdr (args) == NIL)
… …
4039 x = cdr (args); 4062 x = cdr (args);
4040 v = nvalue (car (args)); 4063 v = nvalue (car (args));
4041 } 4064 }
4042 4065
4043 for (; x != NIL; x = cdr (x)) 4066 for (; x != NIL; x = cdr (x))
4044 v = num_op ('+', v, nvalue (car (x))); 4067 v = num_op (NUM_SUB, v, nvalue (car (x)));
4045 4068
4046 s_return (mk_number (SCHEME_A_ v)); 4069 s_return (mk_number (SCHEME_A_ v));
4047 4070
4048 case OP_DIV: /* / */ 4071 case OP_DIV: /* / */
4049 if (cdr (args) == NIL) 4072 if (cdr (args) == NIL)
… …
4056 x = cdr (args); 4079 x = cdr (args);
4057 v = nvalue (car (args)); 4080 v = nvalue (car (args));
4058 } 4081 }
4059 4082
4060 for (; x != NIL; x = cdr (x)) 4083 for (; x != NIL; x = cdr (x))
4061 {
4062 if (!is_zero_rvalue (rvalue (car (x)))) 4084 if (!is_zero_rvalue (rvalue (car (x))))
4063 v = num_div (v, nvalue (car (x))); 4085 v = num_div (v, nvalue (car (x)));
4064 else 4086 else
4065 Error_0 ("/: division by zero"); 4087 Error_0 ("/: division by zero");
4066 }
4067 4088
4068 s_return (mk_number (SCHEME_A_ v)); 4089 s_return (mk_number (SCHEME_A_ v));
4069 4090
4070 case OP_INTDIV: /* quotient */ 4091 case OP_INTDIV: /* quotient */
4071 if (cdr (args) == NIL) 4092 if (cdr (args) == NIL)
… …
4080 } 4101 }
4081 4102
4082 for (; x != NIL; x = cdr (x)) 4103 for (; x != NIL; x = cdr (x))
4083 { 4104 {
4084 if (ivalue (car (x)) != 0) 4105 if (ivalue (car (x)) != 0)
4085 v = num_op ('/', v, nvalue (car (x))); 4106 v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4086 else 4107 else
4087 Error_0 ("quotient: division by zero"); 4108 Error_0 ("quotient: division by zero");
4088 } 4109 }
4089 4110
4090 s_return (mk_number (SCHEME_A_ v)); 4111 s_return (mk_number (SCHEME_A_ v));
… …
4136 } 4157 }
4137 else 4158 else
4138 Error_0 ("set-cdr!: unable to alter immutable pair"); 4159 Error_0 ("set-cdr!: unable to alter immutable pair");
4139 4160
4140 case OP_CHAR2INT: /* char->integer */ 4161 case OP_CHAR2INT: /* char->integer */
4141 s_return (mk_integer (SCHEME_A_ ivalue (x))); 4162 s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4142 4163
4143 case OP_INT2CHAR: /* integer->char */ 4164 case OP_INT2CHAR: /* integer->char */
4144 s_return (mk_character (SCHEME_A_ ivalue (x))); 4165 s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4145 4166
4146 case OP_CHARUPCASE: 4167 case OP_CHARUPCASE:
4147 { 4168 {
4148 unsigned char c = ivalue (x); 4169 unsigned char c = ivalue_unchecked (x);
4149 c = toupper (c); 4170 c = toupper (c);
4150 s_return (mk_character (SCHEME_A_ c)); 4171 s_return (mk_character (SCHEME_A_ c));
4151 } 4172 }
4152 4173
4153 case OP_CHARDNCASE: 4174 case OP_CHARDNCASE:
4154 { 4175 {
4155 unsigned char c = ivalue (x); 4176 unsigned char c = ivalue_unchecked (x);
4156 c = tolower (c); 4177 c = tolower (c);
4157 s_return (mk_character (SCHEME_A_ c)); 4178 s_return (mk_character (SCHEME_A_ c));
4158 } 4179 }
4159 4180
4160 case OP_STR2SYM: /* string->symbol */ 4181 case OP_STR2SYM: /* string->symbol */
… …
4237 Error_1 ("atom->string: not an atom:", x); 4258 Error_1 ("atom->string: not an atom:", x);
4238 } 4259 }
4239 4260
4240 case OP_MKSTRING: /* make-string */ 4261 case OP_MKSTRING: /* make-string */
4241 { 4262 {
4242 int fill = ' '; 4263 int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4243 int len;
4244
4245 len = ivalue (x); 4264 int len = ivalue_unchecked (x);
4246
4247 if (cdr (args) != NIL)
4248 fill = charvalue (cadr (args));
4249 4265
4250 s_return (mk_empty_string (SCHEME_A_ len, fill)); 4266 s_return (mk_empty_string (SCHEME_A_ len, fill));
4251 } 4267 }
4252 4268
4253 case OP_STRLEN: /* string-length */ 4269 case OP_STRLEN: /* string-length */
4254 s_return (mk_integer (SCHEME_A_ strlength (x))); 4270 s_return (mk_integer (SCHEME_A_ strlength (x)));
4255 4271
4256 case OP_STRREF: /* string-ref */ 4272 case OP_STRREF: /* string-ref */
4257 { 4273 {
4258 char *str;
4259 int index;
4260
4261 str = strvalue (x); 4274 char *str = strvalue (x);
4262
4263 index = ivalue (cadr (args)); 4275 int index = ivalue_unchecked (cadr (args));
4264 4276
4265 if (index >= strlength (x)) 4277 if (index >= strlength (x))
4266 Error_1 ("string-ref: out of bounds:", cadr (args)); 4278 Error_1 ("string-ref: out of bounds:", cadr (args));
4267 4279
4268 s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index])); 4280 s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4269 } 4281 }
4270 4282
4271 case OP_STRSET: /* string-set! */ 4283 case OP_STRSET: /* string-set! */
4272 { 4284 {
4273 char *str; 4285 char *str = strvalue (x);
4274 int index; 4286 int index = ivalue_unchecked (cadr (args));
4275 int c; 4287 int c;
4276 4288
4277 if (is_immutable (x)) 4289 if (is_immutable (x))
4278 Error_1 ("string-set!: unable to alter immutable string:", x); 4290 Error_1 ("string-set!: unable to alter immutable string:", x);
4279
4280 str = strvalue (x);
4281
4282 index = ivalue (cadr (args));
4283 4291
4284 if (index >= strlength (x)) 4292 if (index >= strlength (x))
4285 Error_1 ("string-set!: out of bounds:", cadr (args)); 4293 Error_1 ("string-set!: out of bounds:", cadr (args));
4286 4294
4287 c = charvalue (caddr (args)); 4295 c = charvalue (caddr (args));
… …
4310 s_return (newstr); 4318 s_return (newstr);
4311 } 4319 }
4312 4320
4313 case OP_SUBSTR: /* substring */ 4321 case OP_SUBSTR: /* substring */
4314 { 4322 {
4315 char *str; 4323 char *str = strvalue (x);
4316 int index0; 4324 int index0 = ivalue_unchecked (cadr (args));
4317 int index1; 4325 int index1;
4318 int len; 4326 int len;
4319 4327
4320 str = strvalue (x);
4321
4322 index0 = ivalue (cadr (args));
4323
4324 if (index0 > strlength (x)) 4328 if (index0 > strlength (x))
4325 Error_1 ("substring: start out of bounds:", cadr (args)); 4329 Error_1 ("substring: start out of bounds:", cadr (args));
4326 4330
4327 if (cddr (args) != NIL) 4331 if (cddr (args) != NIL)
4328 { 4332 {
4329 index1 = ivalue (caddr (args)); 4333 index1 = ivalue_unchecked (caddr (args));
4330 4334
4331 if (index1 > strlength (x) || index1 < index0) 4335 if (index1 > strlength (x) || index1 < index0)
4332 Error_1 ("substring: end out of bounds:", caddr (args)); 4336 Error_1 ("substring: end out of bounds:", caddr (args));
4333 } 4337 }
4334 else 4338 else
… …
4357 if (SCHEME_V->no_memory) 4361 if (SCHEME_V->no_memory)
4358 s_return (S_SINK); 4362 s_return (S_SINK);
4359#endif 4363#endif
4360 4364
4361 for (x = args, i = 0; is_pair (x); x = cdr (x), i++) 4365 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4362 set_vector_elem (vec, i, car (x)); 4366 vector_set (vec, i, car (x));
4363 4367
4364 s_return (vec); 4368 s_return (vec);
4365 } 4369 }
4366 4370
4367 case OP_MKVECTOR: /* make-vector */ 4371 case OP_MKVECTOR: /* make-vector */
4368 { 4372 {
4369 pointer fill = NIL; 4373 pointer fill = NIL;
4370 int len;
4371 pointer vec; 4374 pointer vec;
4372
4373 len = ivalue (x); 4375 int len = ivalue_unchecked (x);
4374 4376
4375 if (cdr (args) != NIL) 4377 if (cdr (args) != NIL)
4376 fill = cadr (args); 4378 fill = cadr (args);
4377 4379
4378 vec = mk_vector (SCHEME_A_ len); 4380 vec = mk_vector (SCHEME_A_ len);
… …
4381 if (SCHEME_V->no_memory) 4383 if (SCHEME_V->no_memory)
4382 s_return (S_SINK); 4384 s_return (S_SINK);
4383#endif 4385#endif
4384 4386
4385 if (fill != NIL) 4387 if (fill != NIL)
4386 fill_vector (vec, fill); 4388 fill_vector (vec, 0, fill);
4387 4389
4388 s_return (vec); 4390 s_return (vec);
4389 } 4391 }
4390 4392
4391 case OP_VECLEN: /* vector-length */ 4393 case OP_VECLEN: /* vector-length */
4392 s_return (mk_integer (SCHEME_A_ veclength (x))); 4394 s_return (mk_integer (SCHEME_A_ veclength (x)));
4393 4395
4394 case OP_VECREF: /* vector-ref */ 4396 case OP_VECREF: /* vector-ref */
4395 { 4397 {
4396 int index;
4397
4398 index = ivalue (cadr (args)); 4398 int index = ivalue_unchecked (cadr (args));
4399 4399
4400 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4400 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4401 Error_1 ("vector-ref: out of bounds:", cadr (args)); 4401 Error_1 ("vector-ref: out of bounds:", cadr (args));
4402 4402
4403 s_return (vector_elem (x, index)); 4403 s_return (vector_get (x, index));
4404 } 4404 }
4405 4405
4406 case OP_VECSET: /* vector-set! */ 4406 case OP_VECSET: /* vector-set! */
4407 { 4407 {
4408 int index; 4408 int index = ivalue_unchecked (cadr (args));
4409 4409
4410 if (is_immutable (x)) 4410 if (is_immutable (x))
4411 Error_1 ("vector-set!: unable to alter immutable vector:", x); 4411 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4412 4412
4413 index = ivalue (cadr (args));
4414
4415 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4413 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4416 Error_1 ("vector-set!: out of bounds:", cadr (args)); 4414 Error_1 ("vector-set!: out of bounds:", cadr (args));
4417 4415
4418 set_vector_elem (x, index, caddr (args)); 4416 vector_set (x, index, caddr (args));
4419 s_return (x); 4417 s_return (x);
4420 } 4418 }
4421 } 4419 }
4422 4420
4423 return S_T; 4421 if (USE_ERROR_CHECKING) abort ();
4424} 4422}
4425 4423
4426INTERFACE int
4427is_list (SCHEME_P_ pointer a)
4428{
4429 return list_length (SCHEME_A_ a) >= 0;
4430}
4431
4432/* Result is:
4433 proper list: length
4434 circular list: -1
4435 not even a pair: -2
4436 dotted list: -2 minus length before dot
4437*/
4438INTERFACE int
4439list_length (SCHEME_P_ pointer a)
4440{
4441 int i = 0;
4442 pointer slow, fast;
4443
4444 slow = fast = a;
4445
4446 while (1)
4447 {
4448 if (fast == NIL)
4449 return i;
4450
4451 if (!is_pair (fast))
4452 return -2 - i;
4453
4454 fast = cdr (fast);
4455 ++i;
4456
4457 if (fast == NIL)
4458 return i;
4459
4460 if (!is_pair (fast))
4461 return -2 - i;
4462
4463 ++i;
4464 fast = cdr (fast);
4465
4466 /* Safe because we would have already returned if `fast'
4467 encountered a non-pair. */
4468 slow = cdr (slow);
4469
4470 if (fast == slow)
4471 {
4472 /* the fast pointer has looped back around and caught up
4473 with the slow pointer, hence the structure is circular,
4474 not of finite length, and therefore not a list */
4475 return -1;
4476 }
4477 }
4478}
4479
4480static pointer 4424static int
4481opexe_r (SCHEME_P_ enum scheme_opcodes op) 4425opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4482{ 4426{
4483 pointer x = SCHEME_V->args; 4427 pointer x = SCHEME_V->args;
4484 4428
4485 for (;;) 4429 for (;;)
4486 { 4430 {
… …
4506 } 4450 }
4507 4451
4508 s_return (S_T); 4452 s_return (S_T);
4509} 4453}
4510 4454
4511static pointer 4455static int
4512opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4456opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4513{ 4457{
4514 pointer args = SCHEME_V->args; 4458 pointer args = SCHEME_V->args;
4515 pointer a = car (args); 4459 pointer a = car (args);
4516 pointer d = cdr (args); 4460 pointer d = cdr (args);
… …
4528 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4472 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4529 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4473 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4530 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4474 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4531 4475
4532#if USE_CHAR_CLASSIFIERS 4476#if USE_CHAR_CLASSIFIERS
4533 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break; 4477 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4534 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break; 4478 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4535 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break; 4479 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4536 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break; 4480 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4537 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break; 4481 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4538#endif 4482#endif
4539 4483
4540#if USE_PORTS 4484#if USE_PORTS
4541 case OP_PORTP: /* port? */ r = is_port (a) ; break; 4485 case OP_PORTP: /* port? */ r = is_port (a) ; break;
4542 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break; 4486 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
… …
4562 } 4506 }
4563 4507
4564 s_retbool (r); 4508 s_retbool (r);
4565} 4509}
4566 4510
4567static pointer 4511static int
4568opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4512opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4569{ 4513{
4570 pointer args = SCHEME_V->args; 4514 pointer args = SCHEME_V->args;
4571 pointer a = car (args); 4515 pointer a = car (args);
4572 pointer x, y; 4516 pointer x, y;
… …
4658 putstr (SCHEME_A_ "\n"); 4602 putstr (SCHEME_A_ "\n");
4659 4603
4660 if (SCHEME_V->interactive_repl) 4604 if (SCHEME_V->interactive_repl)
4661 s_goto (OP_T0LVL); 4605 s_goto (OP_T0LVL);
4662 else 4606 else
4663 return NIL; 4607 return -1;
4664 } 4608 }
4665 4609
4666 case OP_REVERSE: /* reverse */ 4610 case OP_REVERSE: /* reverse */
4667 s_return (reverse (SCHEME_A_ a)); 4611 s_return (reverse (SCHEME_A_ a));
4668 4612
… …
4725 4669
4726 case OP_QUIT: /* quit */ 4670 case OP_QUIT: /* quit */
4727 if (is_pair (args)) 4671 if (is_pair (args))
4728 SCHEME_V->retcode = ivalue (a); 4672 SCHEME_V->retcode = ivalue (a);
4729 4673
4730 return NIL; 4674 return -1;
4731 4675
4732 case OP_GC: /* gc */ 4676 case OP_GC: /* gc */
4733 gc (SCHEME_A_ NIL, NIL); 4677 gc (SCHEME_A_ NIL, NIL);
4734 s_return (S_T); 4678 s_return (S_T);
4735 4679
… …
4743 4687
4744 case OP_NEWSEGMENT: /* new-segment */ 4688 case OP_NEWSEGMENT: /* new-segment */
4745 if (!is_pair (args) || !is_number (a)) 4689 if (!is_pair (args) || !is_number (a))
4746 Error_0 ("new-segment: argument must be a number"); 4690 Error_0 ("new-segment: argument must be a number");
4747 4691
4748 alloc_cellseg (SCHEME_A_ (int)ivalue (a)); 4692 alloc_cellseg (SCHEME_A_ ivalue (a));
4749 4693
4750 s_return (S_T); 4694 s_return (S_T);
4751 4695
4752 case OP_OBLIST: /* oblist */ 4696 case OP_OBLIST: /* oblist */
4753 s_return (oblist_all_symbols (SCHEME_A)); 4697 s_return (oblist_all_symbols (SCHEME_A));
… …
4782 break; 4726 break;
4783 } 4727 }
4784 4728
4785 p = port_from_filename (SCHEME_A_ strvalue (a), prop); 4729 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4786 4730
4787 if (p == NIL) 4731 s_return (p == NIL ? S_F : p);
4788 s_return (S_F);
4789
4790 s_return (p);
4791 } 4732 }
4792 4733
4793# if USE_STRING_PORTS 4734# if USE_STRING_PORTS
4794 4735
4795 case OP_OPEN_INSTRING: /* open-input-string */ 4736 case OP_OPEN_INSTRING: /* open-input-string */
… …
4810 } 4751 }
4811 4752
4812 p = port_from_string (SCHEME_A_ strvalue (a), 4753 p = port_from_string (SCHEME_A_ strvalue (a),
4813 strvalue (a) + strlength (a), prop); 4754 strvalue (a) + strlength (a), prop);
4814 4755
4815 if (p == NIL) 4756 s_return (p == NIL ? S_F : p);
4816 s_return (S_F);
4817
4818 s_return (p);
4819 } 4757 }
4820 4758
4821 case OP_OPEN_OUTSTRING: /* open-output-string */ 4759 case OP_OPEN_OUTSTRING: /* open-output-string */
4822 { 4760 {
4823 pointer p; 4761 pointer p;
4824 4762
4825 if (a == NIL) 4763 if (a == NIL)
4826 {
4827 p = port_from_scratch (SCHEME_A); 4764 p = port_from_scratch (SCHEME_A);
4828
4829 if (p == NIL)
4830 s_return (S_F);
4831 }
4832 else 4765 else
4833 {
4834 p = port_from_string (SCHEME_A_ strvalue (a), 4766 p = port_from_string (SCHEME_A_ strvalue (a),
4835 strvalue (a) + strlength (a), port_output); 4767 strvalue (a) + strlength (a), port_output);
4836 4768
4837 if (p == NIL) 4769 s_return (p == NIL ? S_F : p);
4838 s_return (S_F);
4839 }
4840
4841 s_return (p);
4842 } 4770 }
4843 4771
4844 case OP_GET_OUTSTRING: /* get-output-string */ 4772 case OP_GET_OUTSTRING: /* get-output-string */
4845 { 4773 {
4846 port *p; 4774 port *p;
… …
4885 case OP_CURR_ENV: /* current-environment */ 4813 case OP_CURR_ENV: /* current-environment */
4886 s_return (SCHEME_V->envir); 4814 s_return (SCHEME_V->envir);
4887 4815
4888 } 4816 }
4889 4817
4890 abort (); 4818 if (USE_ERROR_CHECKING) abort ();
4891} 4819}
4892 4820
4893static pointer 4821static int
4894opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4822opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4895{ 4823{
4896 pointer args = SCHEME_V->args; 4824 pointer args = SCHEME_V->args;
4897 pointer x; 4825 pointer x;
4898 4826
… …
5214 putstr (SCHEME_A_ ")"); 5142 putstr (SCHEME_A_ ")");
5215 s_return (S_T); 5143 s_return (S_T);
5216 } 5144 }
5217 else 5145 else
5218 { 5146 {
5219 pointer elem = vector_elem (vec, i); 5147 pointer elem = vector_get (vec, i);
5220 5148
5221 ivalue_unchecked (cdr (args)) = i + 1; 5149 ivalue_unchecked (cdr (args)) = i + 1;
5222 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5150 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5223 SCHEME_V->args = elem; 5151 SCHEME_V->args = elem;
5224 5152
… …
5228 s_goto (OP_P0LIST); 5156 s_goto (OP_P0LIST);
5229 } 5157 }
5230 } 5158 }
5231 } 5159 }
5232 5160
5233 abort (); 5161 if (USE_ERROR_CHECKING) abort ();
5234} 5162}
5235 5163
5236static pointer 5164static int
5237opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5165opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5238{ 5166{
5239 pointer args = SCHEME_V->args; 5167 pointer args = SCHEME_V->args;
5240 pointer a = car (args); 5168 pointer a = car (args);
5241 pointer x, y; 5169 pointer x, y;
… …
5291 5219
5292 case OP_MACROP: /* macro? */ 5220 case OP_MACROP: /* macro? */
5293 s_retbool (is_macro (a)); 5221 s_retbool (is_macro (a));
5294 } 5222 }
5295 5223
5296 abort (); 5224 if (USE_ERROR_CHECKING) abort ();
5297} 5225}
5298 5226
5227/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5299typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5228typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5300 5229
5301typedef int (*test_predicate)(pointer); 5230typedef int (*test_predicate)(pointer);
5302static int 5231static int
5303is_any (pointer p) 5232tst_any (pointer p)
5304{ 5233{
5305 return 1; 5234 return 1;
5306} 5235}
5307 5236
5308static int 5237static int
5309is_nonneg (pointer p) 5238tst_inonneg (pointer p)
5310{ 5239{
5311 return ivalue (p) >= 0 && is_integer (p); 5240 return is_integer (p) && ivalue_unchecked (p) >= 0;
5312} 5241}
5313 5242
5314static int 5243static int
5315tst_is_list (pointer p) 5244tst_is_list (SCHEME_P_ pointer p)
5316{ 5245{
5317 return p == NIL || is_pair (p); 5246 return p == NIL || is_pair (p);
5318} 5247}
5319 5248
5320/* Correspond carefully with following defines! */ 5249/* Correspond carefully with following defines! */
5321static struct 5250static struct
5322{ 5251{
5323 test_predicate fct; 5252 test_predicate fct;
5324 const char *kind; 5253 const char *kind;
5325} tests[] = 5254} tests[] = {
5326{
5327 { is_any, 0 }, 5255 { tst_any , 0 },
5328 { is_string, "string" }, 5256 { is_string , "string" },
5329 { is_symbol, "symbol" }, 5257 { is_symbol , "symbol" },
5330 { is_port, "port" }, 5258 { is_port , "port" },
5331 { is_inport, "input port" }, 5259 { is_inport , "input port" },
5332 { is_outport, "output port" }, 5260 { is_outport , "output port" },
5333 { is_environment, "environment" }, 5261 { is_environment, "environment" },
5334 { is_pair, "pair" }, 5262 { is_pair , "pair" },
5335 { tst_is_list, "pair or '()" }, 5263 { 0 , "pair or '()" },
5336 { is_character, "character" }, 5264 { is_character , "character" },
5337 { is_vector, "vector" }, 5265 { is_vector , "vector" },
5338 { is_number, "number" }, 5266 { is_number , "number" },
5339 { is_integer, "integer" }, 5267 { is_integer , "integer" },
5340 { is_nonneg, "non-negative integer" } 5268 { tst_inonneg , "non-negative integer" }
5341}; 5269};
5342 5270
5343#define TST_NONE 0 /* TST_NONE used for standard procedures, for internal ops, 0 is used */ 5271#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5344#define TST_ANY "\001" 5272#define TST_ANY "\001"
5345#define TST_STRING "\002" 5273#define TST_STRING "\002"
5346#define TST_SYMBOL "\003" 5274#define TST_SYMBOL "\003"
5347#define TST_PORT "\004" 5275#define TST_PORT "\004"
5348#define TST_INPORT "\005" 5276#define TST_INPORT "\005"
… …
5354#define TST_VECTOR "\013" 5282#define TST_VECTOR "\013"
5355#define TST_NUMBER "\014" 5283#define TST_NUMBER "\014"
5356#define TST_INTEGER "\015" 5284#define TST_INTEGER "\015"
5357#define TST_NATURAL "\016" 5285#define TST_NATURAL "\016"
5358 5286
5287#define INF_ARG 0xff
5288#define UNNAMED_OP ""
5289
5290static const char opnames[] =
5291#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5292#include "opdefines.h"
5293#undef OP_DEF
5294;
5295
5296static const char *
5297opname (int idx)
5298{
5299 const char *name = opnames;
5300
5301 /* should do this at compile time, but would require external program, right? */
5302 while (idx--)
5303 name += strlen (name) + 1;
5304
5305 return *name ? name : "ILLEGAL";
5306}
5307
5308static const char *
5309procname (pointer x)
5310{
5311 return opname (procnum (x));
5312}
5313
5359typedef struct 5314typedef struct
5360{ 5315{
5361 dispatch_func func; 5316 uint8_t func;
5362 char *name; 5317 /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5318 uint8_t builtin;
5319#if USE_ERROR_CHECKING
5363 int min_arity; 5320 uint8_t min_arity;
5364 int max_arity; 5321 uint8_t max_arity;
5365 char arg_tests_encoding[3]; 5322 char arg_tests_encoding[3];
5323#endif
5366} op_code_info; 5324} op_code_info;
5367 5325
5368#define INF_ARG 0xffff
5369
5370static op_code_info dispatch_table[] = { 5326static const op_code_info dispatch_table[] = {
5327#if USE_ERROR_CHECKING
5371#define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest }, 5328#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5329#else
5330#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
5331#endif
5372#include "opdefines.h" 5332#include "opdefines.h"
5373#undef OP_DEF 5333#undef OP_DEF
5374 {0} 5334 {0}
5375}; 5335};
5376 5336
5377static const char *
5378procname (pointer x)
5379{
5380 int n = procnum (x);
5381 const char *name = dispatch_table[n].name;
5382
5383 if (name == 0)
5384 name = "ILLEGAL!";
5385
5386 return name;
5387}
5388
5389/* kernel of this interpreter */ 5337/* kernel of this interpreter */
5390static void 5338static void ecb_hot
5391Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5339Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5392{ 5340{
5393 SCHEME_V->op = op; 5341 SCHEME_V->op = op;
5394 5342
5395 for (;;) 5343 for (;;)
5396 { 5344 {
5397 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5345 const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5398 5346
5399#if USE_ERROR_CHECKING 5347#if USE_ERROR_CHECKING
5400 if (pcd->name) /* if built-in function, check arguments */ 5348 if (pcd->builtin) /* if built-in function, check arguments */
5401 { 5349 {
5402 int ok = 1;
5403 char msg[STRBUFFSIZE]; 5350 char msg[STRBUFFSIZE];
5404 int n = list_length (SCHEME_A_ SCHEME_V->args); 5351 int n = list_length (SCHEME_A_ SCHEME_V->args);
5405 5352
5406 /* Check number of arguments */ 5353 /* Check number of arguments */
5407 if (ecb_expect_false (n < pcd->min_arity)) 5354 if (ecb_expect_false (n < pcd->min_arity))
5408 { 5355 {
5409 ok = 0;
5410 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5356 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5411 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5357 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5358 xError_1 (SCHEME_A_ msg, 0);
5359 continue;
5412 } 5360 }
5413 else if (ecb_expect_false (n > pcd->max_arity)) 5361 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5414 { 5362 {
5415 ok = 0;
5416 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5363 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5417 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5364 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5365 xError_1 (SCHEME_A_ msg, 0);
5366 continue;
5418 } 5367 }
5419 5368 else
5420 if (ecb_expect_false (ok))
5421 { 5369 {
5422 if (*pcd->arg_tests_encoding) 5370 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5423 { 5371 {
5424 int i = 0; 5372 int i = 0;
5425 int j; 5373 int j;
5426 const char *t = pcd->arg_tests_encoding; 5374 const char *t = pcd->arg_tests_encoding;
5427 pointer arglist = SCHEME_V->args; 5375 pointer arglist = SCHEME_V->args;
… …
5430 { 5378 {
5431 pointer arg = car (arglist); 5379 pointer arg = car (arglist);
5432 5380
5433 j = t[0]; 5381 j = t[0];
5434 5382
5383 /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
5384 if (j == TST_LIST[0])
5385 {
5386 if (!tst_is_list (SCHEME_A_ arg))
5387 break;
5388 }
5389 else
5390 {
5435 if (!tests[j - 1].fct (arg)) 5391 if (!tests[j - 1].fct (arg))
5436 break; 5392 break;
5393 }
5437 5394
5438 if (t[1]) /* last test is replicated as necessary */ 5395 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5439 t++; 5396 t++;
5440 5397
5441 arglist = cdr (arglist); 5398 arglist = cdr (arglist);
5442 i++; 5399 i++;
5443 } 5400 }
5444 while (i < n); 5401 while (i < n);
5445 5402
5446 if (i < n) 5403 if (i < n)
5447 { 5404 {
5448 ok = 0;
5449 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); 5405 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
5406 xError_1 (SCHEME_A_ msg, 0);
5407 continue;
5450 } 5408 }
5451 } 5409 }
5452 } 5410 }
5453
5454 if (!ok)
5455 {
5456 if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5457 return;
5458
5459 pcd = dispatch_table + SCHEME_V->op;
5460 }
5461 } 5411 }
5462#endif 5412#endif
5463 5413
5464 ok_to_freely_gc (SCHEME_A); 5414 ok_to_freely_gc (SCHEME_A);
5465 5415
5416 static const dispatch_func dispatch_funcs[] = {
5417 opexe_0,
5418 opexe_1,
5419 opexe_2,
5420 opexe_3,
5421 opexe_4,
5422 opexe_5,
5423 opexe_6,
5424 };
5425
5466 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)) 5426 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5467 return; 5427 return;
5468 5428
5469 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5429 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5470 { 5430 {
5471 xwrstr ("No memory!\n"); 5431 xwrstr ("No memory!\n");
… …
5495mk_proc (SCHEME_P_ enum scheme_opcodes op) 5455mk_proc (SCHEME_P_ enum scheme_opcodes op)
5496{ 5456{
5497 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5457 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5498 set_typeflag (y, (T_PROC | T_ATOM)); 5458 set_typeflag (y, (T_PROC | T_ATOM));
5499 ivalue_unchecked (y) = op; 5459 ivalue_unchecked (y) = op;
5500 set_num_integer (y);
5501 return y; 5460 return y;
5502} 5461}
5503 5462
5504/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5463/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5505static int 5464static int
… …
5570 return OP_C0STREAM; /* cons-stream */ 5529 return OP_C0STREAM; /* cons-stream */
5571 } 5530 }
5572} 5531}
5573 5532
5574#if USE_MULTIPLICITY 5533#if USE_MULTIPLICITY
5575scheme * 5534ecb_cold scheme *
5576scheme_init_new () 5535scheme_init_new ()
5577{ 5536{
5578 scheme *sc = malloc (sizeof (scheme)); 5537 scheme *sc = malloc (sizeof (scheme));
5579 5538
5580 if (!scheme_init (SCHEME_A)) 5539 if (!scheme_init (SCHEME_A))
… …
5585 else 5544 else
5586 return sc; 5545 return sc;
5587} 5546}
5588#endif 5547#endif
5589 5548
5590int 5549ecb_cold int
5591scheme_init (SCHEME_P) 5550scheme_init (SCHEME_P)
5592{ 5551{
5593 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5552 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5594 pointer x; 5553 pointer x;
5595 5554
… …
5668 5627
5669 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) 5628 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5670 assign_syntax (SCHEME_A_ syntax_names[i]); 5629 assign_syntax (SCHEME_A_ syntax_names[i]);
5671 } 5630 }
5672 5631
5632 // TODO: should iterate via strlen, to avoid n² complexity
5673 for (i = 0; i < n; i++) 5633 for (i = 0; i < n; i++)
5674 if (dispatch_table[i].name != 0) 5634 if (dispatch_table[i].builtin)
5675 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5635 assign_proc (SCHEME_A_ i, opname (i));
5676 5636
5677 /* initialization of global pointers to special symbols */ 5637 /* initialization of global pointers to special symbols */
5678 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5638 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5679 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5639 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5680 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5640 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
… …
5719scheme_set_external_data (SCHEME_P_ void *p) 5679scheme_set_external_data (SCHEME_P_ void *p)
5720{ 5680{
5721 SCHEME_V->ext_data = p; 5681 SCHEME_V->ext_data = p;
5722} 5682}
5723 5683
5724void 5684ecb_cold void
5725scheme_deinit (SCHEME_P) 5685scheme_deinit (SCHEME_P)
5726{ 5686{
5727 int i; 5687 int i;
5728 5688
5729#if SHOW_ERROR_LINE 5689#if SHOW_ERROR_LINE

Diff Legend

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