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

Comparing microscheme/scheme.c (file contents):
Revision 1.20 by root, Thu Nov 26 22:53:28 2015 UTC vs.
Revision 1.25 by root, Fri Nov 27 04:37:26 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
… …
223#if USE_MATH 219#if USE_MATH
224static double round_per_R5RS (double x); 220static double round_per_R5RS (double x);
225#endif 221#endif
226static int is_zero_rvalue (RVALUE x); 222static int is_zero_rvalue (RVALUE x);
227 223
228static INLINE int
229num_is_integer (pointer p)
230{
231 return num_is_fixnum (p->object.number);
232}
233
234static num num_zero; 224static num num_zero;
235static num num_one; 225static num num_one;
236 226
237/* macros for cell operations */ 227/* macros for cell operations */
238#define typeflag(p) ((p)->flag + 0) 228#define typeflag(p) ((p)->flag + 0)
239#define set_typeflag(p,v) ((p)->flag = (v)) 229#define set_typeflag(p,v) ((p)->flag = (v))
240#define type(p) (typeflag (p) & T_MASKTYPE) 230#define type(p) (typeflag (p) & T_MASKTYPE)
241 231
242INTERFACE INLINE int 232INTERFACE int
243is_string (pointer p) 233is_string (pointer p)
244{ 234{
245 return type (p) == T_STRING; 235 return type (p) == T_STRING;
246} 236}
247 237
248#define strvalue(p) ((p)->object.string.svalue) 238#define strvalue(p) ((p)->object.string.svalue)
249#define strlength(p) ((p)->object.string.length) 239#define strlength(p) ((p)->object.string.length)
250 240
251INTERFACE int is_list (SCHEME_P_ pointer p); 241INTERFACE int is_list (SCHEME_P_ pointer p);
252 242
253INTERFACE INLINE int 243INTERFACE int
254is_vector (pointer p) 244is_vector (pointer p)
255{ 245{
256 return type (p) == T_VECTOR; 246 return type (p) == T_VECTOR;
257} 247}
258 248
… …
267vector_length (pointer vec) 257vector_length (pointer vec)
268{ 258{
269 return vec->object.vector.length; 259 return vec->object.vector.length;
270} 260}
271 261
272INTERFACE INLINE int 262INTERFACE int
273is_number (pointer p) 263is_number (pointer p)
274{ 264{
275 return type (p) == T_NUMBER; 265 return type (p) == T_NUMBER;
276} 266}
277 267
278INTERFACE INLINE int 268INTERFACE int
279is_integer (pointer p) 269is_integer (pointer p)
280{ 270{
281 if (!is_number (p)) 271 return is_number (p) && num_is_fixnum (p->object.number);
282 return 0;
283
284 if (num_is_integer (p) || ivalue (p) == rvalue (p))
285 return 1;
286
287 return 0;
288} 272}
289 273
290INTERFACE INLINE int 274INTERFACE int
291is_real (pointer p) 275is_real (pointer p)
292{ 276{
293 return is_number (p) && !num_is_fixnum (p->object.number); 277 return is_number (p) && !num_is_fixnum (p->object.number);
294} 278}
295 279
296INTERFACE INLINE int 280INTERFACE int
297is_character (pointer p) 281is_character (pointer p)
298{ 282{
299 return type (p) == T_CHARACTER; 283 return type (p) == T_CHARACTER;
300} 284}
301 285
302INTERFACE INLINE char * 286INTERFACE char *
303string_value (pointer p) 287string_value (pointer p)
304{ 288{
305 return strvalue (p); 289 return strvalue (p);
306} 290}
307 291
308INLINE num 292ecb_inline num
309nvalue (pointer p) 293nvalue (pointer p)
310{ 294{
311 return (p)->object.number; 295 return (p)->object.number;
312} 296}
313 297
… …
343#else 327#else
344# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 328# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
345# define set_num_integer(p) 0 329# define set_num_integer(p) 0
346# define set_num_real(p) 0 330# define set_num_real(p) 0
347#endif 331#endif
332
348INTERFACE long 333INTERFACE long
349charvalue (pointer p) 334charvalue (pointer p)
350{ 335{
351 return ivalue_unchecked (p); 336 return ivalue_unchecked (p);
352} 337}
353 338
354INTERFACE INLINE int 339INTERFACE int
355is_port (pointer p) 340is_port (pointer p)
356{ 341{
357 return type (p) == T_PORT; 342 return type (p) == T_PORT;
358} 343}
359 344
360INTERFACE INLINE int 345INTERFACE int
361is_inport (pointer p) 346is_inport (pointer p)
362{ 347{
363 return is_port (p) && p->object.port->kind & port_input; 348 return is_port (p) && p->object.port->kind & port_input;
364} 349}
365 350
366INTERFACE INLINE int 351INTERFACE int
367is_outport (pointer p) 352is_outport (pointer p)
368{ 353{
369 return is_port (p) && p->object.port->kind & port_output; 354 return is_port (p) && p->object.port->kind & port_output;
370} 355}
371 356
372INTERFACE INLINE int 357INTERFACE int
373is_pair (pointer p) 358is_pair (pointer p)
374{ 359{
375 return type (p) == T_PAIR; 360 return type (p) == T_PAIR;
376} 361}
377 362
… …
409pair_cdr (pointer p) 394pair_cdr (pointer p)
410{ 395{
411 return cdr (p); 396 return cdr (p);
412} 397}
413 398
414INTERFACE INLINE int 399INTERFACE int
415is_symbol (pointer p) 400is_symbol (pointer p)
416{ 401{
417 return type (p) == T_SYMBOL; 402 return type (p) == T_SYMBOL;
418} 403}
419 404
420INTERFACE INLINE char * 405INTERFACE char *
421symname (pointer p) 406symname (pointer p)
422{ 407{
423 return strvalue (car (p)); 408 return strvalue (car (p));
424} 409}
425 410
426#if USE_PLIST 411#if USE_PLIST
427SCHEME_EXPORT INLINE int 412SCHEME_EXPORT int
428hasprop (pointer p) 413hasprop (pointer p)
429{ 414{
430 return typeflag (p) & T_SYMBOL; 415 return typeflag (p) & T_SYMBOL;
431} 416}
432 417
433# define symprop(p) cdr(p) 418# define symprop(p) cdr(p)
434#endif 419#endif
435 420
436INTERFACE INLINE int 421INTERFACE int
437is_syntax (pointer p) 422is_syntax (pointer p)
438{ 423{
439 return typeflag (p) & T_SYNTAX; 424 return typeflag (p) & T_SYNTAX;
440} 425}
441 426
442INTERFACE INLINE int 427INTERFACE int
443is_proc (pointer p) 428is_proc (pointer p)
444{ 429{
445 return type (p) == T_PROC; 430 return type (p) == T_PROC;
446} 431}
447 432
448INTERFACE INLINE int 433INTERFACE int
449is_foreign (pointer p) 434is_foreign (pointer p)
450{ 435{
451 return type (p) == T_FOREIGN; 436 return type (p) == T_FOREIGN;
452} 437}
453 438
454INTERFACE INLINE char * 439INTERFACE char *
455syntaxname (pointer p) 440syntaxname (pointer p)
456{ 441{
457 return strvalue (car (p)); 442 return strvalue (car (p));
458} 443}
459 444
460#define procnum(p) ivalue (p) 445#define procnum(p) ivalue (p)
461static const char *procname (pointer x); 446static const char *procname (pointer x);
462 447
463INTERFACE INLINE int 448INTERFACE int
464is_closure (pointer p) 449is_closure (pointer p)
465{ 450{
466 return type (p) == T_CLOSURE; 451 return type (p) == T_CLOSURE;
467} 452}
468 453
469INTERFACE INLINE int 454INTERFACE int
470is_macro (pointer p) 455is_macro (pointer p)
471{ 456{
472 return type (p) == T_MACRO; 457 return type (p) == T_MACRO;
473} 458}
474 459
475INTERFACE INLINE pointer 460INTERFACE pointer
476closure_code (pointer p) 461closure_code (pointer p)
477{ 462{
478 return car (p); 463 return car (p);
479} 464}
480 465
481INTERFACE INLINE pointer 466INTERFACE pointer
482closure_env (pointer p) 467closure_env (pointer p)
483{ 468{
484 return cdr (p); 469 return cdr (p);
485} 470}
486 471
487INTERFACE INLINE int 472INTERFACE int
488is_continuation (pointer p) 473is_continuation (pointer p)
489{ 474{
490 return type (p) == T_CONTINUATION; 475 return type (p) == T_CONTINUATION;
491} 476}
492 477
493#define cont_dump(p) cdr (p) 478#define cont_dump(p) cdr (p)
494#define set_cont_dump(p,v) set_cdr ((p), (v)) 479#define set_cont_dump(p,v) set_cdr ((p), (v))
495 480
496/* To do: promise should be forced ONCE only */ 481/* To do: promise should be forced ONCE only */
497INTERFACE INLINE int 482INTERFACE int
498is_promise (pointer p) 483is_promise (pointer p)
499{ 484{
500 return type (p) == T_PROMISE; 485 return type (p) == T_PROMISE;
501} 486}
502 487
503INTERFACE INLINE int 488INTERFACE int
504is_environment (pointer p) 489is_environment (pointer p)
505{ 490{
506 return type (p) == T_ENVIRONMENT; 491 return type (p) == T_ENVIRONMENT;
507} 492}
508 493
… …
514 499
515#define is_mark(p) (typeflag (p) & T_MARK) 500#define is_mark(p) (typeflag (p) & T_MARK)
516#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 501#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
517#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 502#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518 503
519INTERFACE INLINE int 504INTERFACE int
520is_immutable (pointer p) 505is_immutable (pointer p)
521{ 506{
522 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 507 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523} 508}
524 509
525INTERFACE INLINE void 510INTERFACE void
526setimmutable (pointer p) 511setimmutable (pointer p)
527{ 512{
528#if USE_ERROR_CHECKING 513#if USE_ERROR_CHECKING
529 set_typeflag (p, typeflag (p) | T_IMMUTABLE); 514 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
530#endif 515#endif
531} 516}
532 517
533#if USE_CHAR_CLASSIFIERS 518#if USE_CHAR_CLASSIFIERS
534static INLINE int 519ecb_inline int
535Cisalpha (int c) 520Cisalpha (int c)
536{ 521{
537 return isascii (c) && isalpha (c); 522 return isascii (c) && isalpha (c);
538} 523}
539 524
540static INLINE int 525ecb_inline int
541Cisdigit (int c) 526Cisdigit (int c)
542{ 527{
543 return isascii (c) && isdigit (c); 528 return isascii (c) && isdigit (c);
544} 529}
545 530
546static INLINE int 531ecb_inline int
547Cisspace (int c) 532Cisspace (int c)
548{ 533{
549 return isascii (c) && isspace (c); 534 return isascii (c) && isspace (c);
550} 535}
551 536
552static INLINE int 537ecb_inline int
553Cisupper (int c) 538Cisupper (int c)
554{ 539{
555 return isascii (c) && isupper (c); 540 return isascii (c) && isupper (c);
556} 541}
557 542
558static INLINE int 543ecb_inline int
559Cislower (int c) 544Cislower (int c)
560{ 545{
561 return isascii (c) && islower (c); 546 return isascii (c) && islower (c);
562} 547}
563#endif 548#endif
… …
624#endif 609#endif
625 610
626static int file_push (SCHEME_P_ const char *fname); 611static int file_push (SCHEME_P_ const char *fname);
627static void file_pop (SCHEME_P); 612static void file_pop (SCHEME_P);
628static int file_interactive (SCHEME_P); 613static int file_interactive (SCHEME_P);
629static INLINE int is_one_of (char *s, int c); 614ecb_inline int is_one_of (char *s, int c);
630static int alloc_cellseg (SCHEME_P_ int n); 615static int alloc_cellseg (SCHEME_P_ int n);
631static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 616ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632static void finalize_cell (SCHEME_P_ pointer a); 617static void finalize_cell (SCHEME_P_ pointer a);
633static int count_consecutive_cells (pointer x, int needed); 618static int count_consecutive_cells (pointer x, int needed);
634static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 619static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
635static pointer mk_number (SCHEME_P_ const num n); 620static pointer mk_number (SCHEME_P_ const num n);
636static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 621static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
… …
653static int basic_inchar (port *pt); 638static int basic_inchar (port *pt);
654static int inchar (SCHEME_P); 639static int inchar (SCHEME_P);
655static void backchar (SCHEME_P_ int c); 640static void backchar (SCHEME_P_ int c);
656static char *readstr_upto (SCHEME_P_ char *delim); 641static char *readstr_upto (SCHEME_P_ char *delim);
657static pointer readstrexp (SCHEME_P); 642static pointer readstrexp (SCHEME_P);
658static INLINE int skipspace (SCHEME_P); 643ecb_inline int skipspace (SCHEME_P);
659static int token (SCHEME_P); 644static int token (SCHEME_P);
660static void printslashstring (SCHEME_P_ char *s, int len); 645static void printslashstring (SCHEME_P_ char *s, int len);
661static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 646static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
662static void printatom (SCHEME_P_ pointer l, int f); 647static void printatom (SCHEME_P_ pointer l, int f);
663static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 648static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
781 766
782 num_set_ivalue (ret, res); 767 num_set_ivalue (ret, res);
783 return ret; 768 return ret;
784} 769}
785 770
786/* this completely disrespects NaNs */ 771/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787static int 772static int
788num_cmp (num a, num b) 773num_cmp (num a, num b)
789{ 774{
790 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 775 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791 int ret; 776 int ret;
… …
834#endif 819#endif
835 820
836static int 821static int
837is_zero_rvalue (RVALUE x) 822is_zero_rvalue (RVALUE x)
838{ 823{
824 return x == 0;
825#if 0
839#if USE_REAL 826#if USE_REAL
840 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 827 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
841#else 828#else
842 return x == 0; 829 return x == 0;
830#endif
843#endif 831#endif
844} 832}
845 833
846/* allocate new cell segment */ 834/* allocate new cell segment */
847static int 835static int
… …
919 907
920 return n; 908 return n;
921} 909}
922 910
923/* get new cell. parameter a, b is marked by gc. */ 911/* get new cell. parameter a, b is marked by gc. */
924static INLINE pointer 912ecb_inline pointer
925get_cell_x (SCHEME_P_ pointer a, pointer b) 913get_cell_x (SCHEME_P_ pointer a, pointer b)
926{ 914{
927 if (ecb_expect_false (SCHEME_V->free_cell == NIL)) 915 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928 { 916 {
929 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 917 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
… …
1007 push_recent_alloc (SCHEME_A_ v, NIL); 995 push_recent_alloc (SCHEME_A_ v, NIL);
1008 996
1009 return v; 997 return v;
1010} 998}
1011 999
1012static INLINE void 1000ecb_inline void
1013ok_to_freely_gc (SCHEME_P) 1001ok_to_freely_gc (SCHEME_P)
1014{ 1002{
1015 set_car (S_SINK, NIL); 1003 set_car (S_SINK, NIL);
1016} 1004}
1017 1005
… …
1081 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1069 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))); 1070 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1083 return x; 1071 return x;
1084} 1072}
1085 1073
1086static INLINE pointer 1074ecb_inline pointer
1087oblist_find_by_name (SCHEME_P_ const char *name) 1075oblist_find_by_name (SCHEME_P_ const char *name)
1088{ 1076{
1089 int location; 1077 int location;
1090 pointer x; 1078 pointer x;
1091 char *s; 1079 char *s;
… …
1124oblist_initial_value (SCHEME_P) 1112oblist_initial_value (SCHEME_P)
1125{ 1113{
1126 return NIL; 1114 return NIL;
1127} 1115}
1128 1116
1129static INLINE pointer 1117ecb_inline pointer
1130oblist_find_by_name (SCHEME_P_ const char *name) 1118oblist_find_by_name (SCHEME_P_ const char *name)
1131{ 1119{
1132 pointer x; 1120 pointer x;
1133 char *s; 1121 char *s;
1134 1122
… …
2232 } 2220 }
2233 } 2221 }
2234} 2222}
2235 2223
2236/* check c is in chars */ 2224/* check c is in chars */
2237static INLINE int 2225ecb_inline int
2238is_one_of (char *s, int c) 2226is_one_of (char *s, int c)
2239{ 2227{
2240 if (c == EOF) 2228 if (c == EOF)
2241 return 1; 2229 return 1;
2242 2230
2243 return !!strchr (s, c); 2231 return !!strchr (s, c);
2244} 2232}
2245 2233
2246/* skip white characters */ 2234/* skip white characters */
2247static INLINE int 2235ecb_inline int
2248skipspace (SCHEME_P) 2236skipspace (SCHEME_P)
2249{ 2237{
2250 int c, curr_line = 0; 2238 int c, curr_line = 0;
2251 2239
2252 do 2240 do
… …
2480 { 2468 {
2481 p = SCHEME_V->strbuff; 2469 p = SCHEME_V->strbuff;
2482 2470
2483 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2471 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2484 { 2472 {
2485 if (num_is_integer (l)) 2473 if (is_integer (l))
2486 xnum (p, ivalue_unchecked (l)); 2474 xnum (p, ivalue_unchecked (l));
2487#if USE_REAL 2475#if USE_REAL
2488 else 2476 else
2489 { 2477 {
2490 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2478 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
… …
2745 return 0; 2733 return 0;
2746 } 2734 }
2747 else if (is_number (a)) 2735 else if (is_number (a))
2748 { 2736 {
2749 if (is_number (b)) 2737 if (is_number (b))
2750 if (num_is_integer (a) == num_is_integer (b))
2751 return num_cmp (nvalue (a), nvalue (b)) == 0; 2738 return num_cmp (nvalue (a), nvalue (b)) == 0;
2752 2739
2753 return 0; 2740 return 0;
2754 } 2741 }
2755 else if (is_character (a)) 2742 else if (is_character (a))
2756 { 2743 {
… …
2823 2810
2824 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2811 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825 setenvironment (SCHEME_V->envir); 2812 setenvironment (SCHEME_V->envir);
2826} 2813}
2827 2814
2828static INLINE void 2815ecb_inline void
2829new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2816new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830{ 2817{
2831 pointer slot = immutable_cons (variable, value); 2818 pointer slot = immutable_cons (variable, value);
2832 2819
2833 if (is_vector (car (env))) 2820 if (is_vector (car (env)))
… …
2873 return NIL; 2860 return NIL;
2874} 2861}
2875 2862
2876#else /* USE_ALIST_ENV */ 2863#else /* USE_ALIST_ENV */
2877 2864
2878static INLINE void 2865ecb_inline void
2879new_frame_in_env (SCHEME_P_ pointer old_env) 2866new_frame_in_env (SCHEME_P_ pointer old_env)
2880{ 2867{
2881 SCHEME_V->envir = immutable_cons (NIL, old_env); 2868 SCHEME_V->envir = immutable_cons (NIL, old_env);
2882 setenvironment (SCHEME_V->envir); 2869 setenvironment (SCHEME_V->envir);
2883} 2870}
2884 2871
2885static INLINE void 2872ecb_inline void
2886new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2873new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887{ 2874{
2888 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2875 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889} 2876}
2890 2877
… …
2912 return NIL; 2899 return NIL;
2913} 2900}
2914 2901
2915#endif /* USE_ALIST_ENV else */ 2902#endif /* USE_ALIST_ENV else */
2916 2903
2917static INLINE void 2904ecb_inline void
2918new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2905new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919{ 2906{
2920 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2907 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921} 2908}
2922 2909
2923static INLINE void 2910ecb_inline void
2924set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2911set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925{ 2912{
2926 set_cdr (slot, value); 2913 set_cdr (slot, value);
2927} 2914}
2928 2915
2929static INLINE pointer 2916ecb_inline pointer
2930slot_value_in_env (pointer slot) 2917slot_value_in_env (pointer slot)
2931{ 2918{
2932 return cdr (slot); 2919 return cdr (slot);
2933} 2920}
2934 2921
… …
3062 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3049 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063 3050
3064 return 0; 3051 return 0;
3065} 3052}
3066 3053
3067static INLINE void 3054ecb_inline void
3068dump_stack_reset (SCHEME_P) 3055dump_stack_reset (SCHEME_P)
3069{ 3056{
3070 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3057 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071 SCHEME_V->dump = (pointer)+0; 3058 SCHEME_V->dump = (pointer)+0;
3072} 3059}
3073 3060
3074static INLINE void 3061ecb_inline void
3075dump_stack_initialize (SCHEME_P) 3062dump_stack_initialize (SCHEME_P)
3076{ 3063{
3077 SCHEME_V->dump_size = 0; 3064 SCHEME_V->dump_size = 0;
3078 SCHEME_V->dump_base = 0; 3065 SCHEME_V->dump_base = 0;
3079 dump_stack_reset (SCHEME_A); 3066 dump_stack_reset (SCHEME_A);
… …
3146 SCHEME_V->dump = (pointer)(uintptr_t)i; 3133 SCHEME_V->dump = (pointer)(uintptr_t)i;
3147} 3134}
3148 3135
3149#else 3136#else
3150 3137
3151static INLINE void 3138ecb_inline void
3152dump_stack_reset (SCHEME_P) 3139dump_stack_reset (SCHEME_P)
3153{ 3140{
3154 SCHEME_V->dump = NIL; 3141 SCHEME_V->dump = NIL;
3155} 3142}
3156 3143
3157static INLINE void 3144ecb_inline void
3158dump_stack_initialize (SCHEME_P) 3145dump_stack_initialize (SCHEME_P)
3159{ 3146{
3160 dump_stack_reset (SCHEME_A); 3147 dump_stack_reset (SCHEME_A);
3161} 3148}
3162 3149
… …
3912 SCHEME_V->code = car (args); 3899 SCHEME_V->code = car (args);
3913 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); 3900 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3914 s_goto (OP_APPLY); 3901 s_goto (OP_APPLY);
3915 } 3902 }
3916 3903
3917 abort (); 3904 if (USE_ERROR_CHECKING) abort ();
3918} 3905}
3919 3906
3920static int 3907static int
3921opexe_1 (SCHEME_P_ enum scheme_opcodes op) 3908opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3922{ 3909{
… …
3930 3917
3931 switch (op) 3918 switch (op)
3932 { 3919 {
3933#if USE_MATH 3920#if USE_MATH
3934 case OP_INEX2EX: /* inexact->exact */ 3921 case OP_INEX2EX: /* inexact->exact */
3935 if (num_is_integer (x)) 3922 if (is_integer (x))
3936 s_return (x); 3923 s_return (x);
3937 else if (modf (rvalue_unchecked (x), &dd) == 0) 3924 else if (modf (rvalue_unchecked (x), &dd) == 0)
3938 s_return (mk_integer (SCHEME_A_ ivalue (x))); 3925 s_return (mk_integer (SCHEME_A_ ivalue (x)));
3939 else 3926 else
3940 Error_1 ("inexact->exact: not integral:", x); 3927 Error_1 ("inexact->exact: not integral:", x);
… …
3963 { 3950 {
3964 RVALUE result; 3951 RVALUE result;
3965 int real_result = 1; 3952 int real_result = 1;
3966 pointer y = cadr (args); 3953 pointer y = cadr (args);
3967 3954
3968 if (num_is_integer (x) && num_is_integer (y)) 3955 if (is_integer (x) && is_integer (y))
3969 real_result = 0; 3956 real_result = 0;
3970 3957
3971 /* This 'if' is an R5RS compatibility fix. */ 3958 /* This 'if' is an R5RS compatibility fix. */
3972 /* NOTE: Remove this 'if' fix for R6RS. */ 3959 /* NOTE: Remove this 'if' fix for R6RS. */
3973 if (rvalue (x) == 0 && rvalue (y) < 0) 3960 if (rvalue (x) == 0 && rvalue (y) < 0)
… …
4015 4002
4016 case OP_ADD: /* + */ 4003 case OP_ADD: /* + */
4017 v = num_zero; 4004 v = num_zero;
4018 4005
4019 for (x = args; x != NIL; x = cdr (x)) 4006 for (x = args; x != NIL; x = cdr (x))
4020 v = num_op ('+', v, nvalue (car (x))); 4007 v = num_op (NUM_ADD, v, nvalue (car (x)));
4021 4008
4022 s_return (mk_number (SCHEME_A_ v)); 4009 s_return (mk_number (SCHEME_A_ v));
4023 4010
4024 case OP_MUL: /* * */ 4011 case OP_MUL: /* * */
4025 v = num_one; 4012 v = num_one;
4026 4013
4027 for (x = args; x != NIL; x = cdr (x)) 4014 for (x = args; x != NIL; x = cdr (x))
4028 v = num_op ('+', v, nvalue (car (x))); 4015 v = num_op (NUM_MUL, v, nvalue (car (x)));
4029 4016
4030 s_return (mk_number (SCHEME_A_ v)); 4017 s_return (mk_number (SCHEME_A_ v));
4031 4018
4032 case OP_SUB: /* - */ 4019 case OP_SUB: /* - */
4033 if (cdr (args) == NIL) 4020 if (cdr (args) == NIL)
… …
4040 x = cdr (args); 4027 x = cdr (args);
4041 v = nvalue (car (args)); 4028 v = nvalue (car (args));
4042 } 4029 }
4043 4030
4044 for (; x != NIL; x = cdr (x)) 4031 for (; x != NIL; x = cdr (x))
4045 v = num_op ('+', v, nvalue (car (x))); 4032 v = num_op (NUM_SUB, v, nvalue (car (x)));
4046 4033
4047 s_return (mk_number (SCHEME_A_ v)); 4034 s_return (mk_number (SCHEME_A_ v));
4048 4035
4049 case OP_DIV: /* / */ 4036 case OP_DIV: /* / */
4050 if (cdr (args) == NIL) 4037 if (cdr (args) == NIL)
… …
4057 x = cdr (args); 4044 x = cdr (args);
4058 v = nvalue (car (args)); 4045 v = nvalue (car (args));
4059 } 4046 }
4060 4047
4061 for (; x != NIL; x = cdr (x)) 4048 for (; x != NIL; x = cdr (x))
4062 {
4063 if (!is_zero_rvalue (rvalue (car (x)))) 4049 if (!is_zero_rvalue (rvalue (car (x))))
4064 v = num_div (v, nvalue (car (x))); 4050 v = num_div (v, nvalue (car (x)));
4065 else 4051 else
4066 Error_0 ("/: division by zero"); 4052 Error_0 ("/: division by zero");
4067 }
4068 4053
4069 s_return (mk_number (SCHEME_A_ v)); 4054 s_return (mk_number (SCHEME_A_ v));
4070 4055
4071 case OP_INTDIV: /* quotient */ 4056 case OP_INTDIV: /* quotient */
4072 if (cdr (args) == NIL) 4057 if (cdr (args) == NIL)
… …
4081 } 4066 }
4082 4067
4083 for (; x != NIL; x = cdr (x)) 4068 for (; x != NIL; x = cdr (x))
4084 { 4069 {
4085 if (ivalue (car (x)) != 0) 4070 if (ivalue (car (x)) != 0)
4086 v = num_op ('/', v, nvalue (car (x))); 4071 v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087 else 4072 else
4088 Error_0 ("quotient: division by zero"); 4073 Error_0 ("quotient: division by zero");
4089 } 4074 }
4090 4075
4091 s_return (mk_number (SCHEME_A_ v)); 4076 s_return (mk_number (SCHEME_A_ v));
… …
4419 set_vector_elem (x, index, caddr (args)); 4404 set_vector_elem (x, index, caddr (args));
4420 s_return (x); 4405 s_return (x);
4421 } 4406 }
4422 } 4407 }
4423 4408
4424 abort (); 4409 if (USE_ERROR_CHECKING) abort ();
4425} 4410}
4426 4411
4427INTERFACE int 4412INTERFACE int
4428is_list (SCHEME_P_ pointer a) 4413is_list (SCHEME_P_ pointer a)
4429{ 4414{
… …
4783 break; 4768 break;
4784 } 4769 }
4785 4770
4786 p = port_from_filename (SCHEME_A_ strvalue (a), prop); 4771 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787 4772
4788 if (p == NIL) 4773 s_return (p == NIL ? S_F : p);
4789 s_return (S_F);
4790
4791 s_return (p);
4792 } 4774 }
4793 4775
4794# if USE_STRING_PORTS 4776# if USE_STRING_PORTS
4795 4777
4796 case OP_OPEN_INSTRING: /* open-input-string */ 4778 case OP_OPEN_INSTRING: /* open-input-string */
… …
4811 } 4793 }
4812 4794
4813 p = port_from_string (SCHEME_A_ strvalue (a), 4795 p = port_from_string (SCHEME_A_ strvalue (a),
4814 strvalue (a) + strlength (a), prop); 4796 strvalue (a) + strlength (a), prop);
4815 4797
4816 if (p == NIL) 4798 s_return (p == NIL ? S_F : p);
4817 s_return (S_F);
4818
4819 s_return (p);
4820 } 4799 }
4821 4800
4822 case OP_OPEN_OUTSTRING: /* open-output-string */ 4801 case OP_OPEN_OUTSTRING: /* open-output-string */
4823 { 4802 {
4824 pointer p; 4803 pointer p;
4825 4804
4826 if (a == NIL) 4805 if (a == NIL)
4827 {
4828 p = port_from_scratch (SCHEME_A); 4806 p = port_from_scratch (SCHEME_A);
4829
4830 if (p == NIL)
4831 s_return (S_F);
4832 }
4833 else 4807 else
4834 {
4835 p = port_from_string (SCHEME_A_ strvalue (a), 4808 p = port_from_string (SCHEME_A_ strvalue (a),
4836 strvalue (a) + strlength (a), port_output); 4809 strvalue (a) + strlength (a), port_output);
4837 4810
4838 if (p == NIL) 4811 s_return (p == NIL ? S_F : p);
4839 s_return (S_F);
4840 }
4841
4842 s_return (p);
4843 } 4812 }
4844 4813
4845 case OP_GET_OUTSTRING: /* get-output-string */ 4814 case OP_GET_OUTSTRING: /* get-output-string */
4846 { 4815 {
4847 port *p; 4816 port *p;
… …
4886 case OP_CURR_ENV: /* current-environment */ 4855 case OP_CURR_ENV: /* current-environment */
4887 s_return (SCHEME_V->envir); 4856 s_return (SCHEME_V->envir);
4888 4857
4889 } 4858 }
4890 4859
4891 abort (); 4860 if (USE_ERROR_CHECKING) abort ();
4892} 4861}
4893 4862
4894static int 4863static int
4895opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4864opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896{ 4865{
… …
5229 s_goto (OP_P0LIST); 5198 s_goto (OP_P0LIST);
5230 } 5199 }
5231 } 5200 }
5232 } 5201 }
5233 5202
5234 abort (); 5203 if (USE_ERROR_CHECKING) abort ();
5235} 5204}
5236 5205
5237static int 5206static int
5238opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5207opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239{ 5208{
… …
5292 5261
5293 case OP_MACROP: /* macro? */ 5262 case OP_MACROP: /* macro? */
5294 s_retbool (is_macro (a)); 5263 s_retbool (is_macro (a));
5295 } 5264 }
5296 5265
5297 abort (); 5266 if (USE_ERROR_CHECKING) abort ();
5298} 5267}
5299 5268
5300/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5269/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5301typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5270typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5302 5271
… …
5401#undef OP_DEF 5370#undef OP_DEF
5402 {0} 5371 {0}
5403}; 5372};
5404 5373
5405/* kernel of this interpreter */ 5374/* kernel of this interpreter */
5406static void 5375static void ecb_hot
5407Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5376Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408{ 5377{
5409 SCHEME_V->op = op; 5378 SCHEME_V->op = op;
5410 5379
5411 for (;;) 5380 for (;;)
… …
5413 const op_code_info *pcd = dispatch_table + SCHEME_V->op; 5382 const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5414 5383
5415#if USE_ERROR_CHECKING 5384#if USE_ERROR_CHECKING
5416 if (pcd->builtin) /* if built-in function, check arguments */ 5385 if (pcd->builtin) /* if built-in function, check arguments */
5417 { 5386 {
5418 int ok = 1;
5419 char msg[STRBUFFSIZE]; 5387 char msg[STRBUFFSIZE];
5420 int n = list_length (SCHEME_A_ SCHEME_V->args); 5388 int n = list_length (SCHEME_A_ SCHEME_V->args);
5421 5389
5422 /* Check number of arguments */ 5390 /* Check number of arguments */
5423 if (ecb_expect_false (n < pcd->min_arity)) 5391 if (ecb_expect_false (n < pcd->min_arity))
5424 { 5392 {
5425 ok = 0;
5426 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5393 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5427 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5394 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5395 xError_1 (SCHEME_A_ msg, 0);
5396 continue;
5428 } 5397 }
5429 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG)) 5398 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5430 { 5399 {
5431 ok = 0;
5432 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5400 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5433 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5401 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5402 xError_1 (SCHEME_A_ msg, 0);
5403 continue;
5434 } 5404 }
5435 else 5405 else
5436 { 5406 {
5437 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */ 5407 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5438 { 5408 {
… …
5458 } 5428 }
5459 while (i < n); 5429 while (i < n);
5460 5430
5461 if (i < n) 5431 if (i < n)
5462 { 5432 {
5463 ok = 0;
5464 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind); 5433 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
5434 xError_1 (SCHEME_A_ msg, 0);
5435 continue;
5465 } 5436 }
5466 } 5437 }
5467 }
5468
5469 if (!ok)
5470 {
5471 /* tinyscheme tested for returncode, but Error_1 always diverts? */
5472 xError_1 (SCHEME_A_ msg, 0);
5473 continue;
5474 } 5438 }
5475 } 5439 }
5476#endif 5440#endif
5477 5441
5478 ok_to_freely_gc (SCHEME_A); 5442 ok_to_freely_gc (SCHEME_A);
… …
5594 return OP_C0STREAM; /* cons-stream */ 5558 return OP_C0STREAM; /* cons-stream */
5595 } 5559 }
5596} 5560}
5597 5561
5598#if USE_MULTIPLICITY 5562#if USE_MULTIPLICITY
5599scheme * 5563ecb_cold scheme *
5600scheme_init_new () 5564scheme_init_new ()
5601{ 5565{
5602 scheme *sc = malloc (sizeof (scheme)); 5566 scheme *sc = malloc (sizeof (scheme));
5603 5567
5604 if (!scheme_init (SCHEME_A)) 5568 if (!scheme_init (SCHEME_A))
… …
5609 else 5573 else
5610 return sc; 5574 return sc;
5611} 5575}
5612#endif 5576#endif
5613 5577
5614int 5578ecb_cold int
5615scheme_init (SCHEME_P) 5579scheme_init (SCHEME_P)
5616{ 5580{
5617 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5581 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5618 pointer x; 5582 pointer x;
5619 5583
… …
5744scheme_set_external_data (SCHEME_P_ void *p) 5708scheme_set_external_data (SCHEME_P_ void *p)
5745{ 5709{
5746 SCHEME_V->ext_data = p; 5710 SCHEME_V->ext_data = p;
5747} 5711}
5748 5712
5749void 5713ecb_cold void
5750scheme_deinit (SCHEME_P) 5714scheme_deinit (SCHEME_P)
5751{ 5715{
5752 int i; 5716 int i;
5753 5717
5754#if SHOW_ERROR_LINE 5718#if SHOW_ERROR_LINE

Diff Legend

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