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

Comparing microscheme/scheme.c (file contents):
Revision 1.22 by root, Thu Nov 26 23:26:00 2015 UTC vs.
Revision 1.23 by root, Fri Nov 27 02:06:36 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 224ecb_inline int
229num_is_integer (pointer p) 225num_is_integer (pointer p)
230{ 226{
231 return num_is_fixnum (p->object.number); 227 return num_is_fixnum (p->object.number);
232} 228}
233 229
… …
237/* macros for cell operations */ 233/* macros for cell operations */
238#define typeflag(p) ((p)->flag + 0) 234#define typeflag(p) ((p)->flag + 0)
239#define set_typeflag(p,v) ((p)->flag = (v)) 235#define set_typeflag(p,v) ((p)->flag = (v))
240#define type(p) (typeflag (p) & T_MASKTYPE) 236#define type(p) (typeflag (p) & T_MASKTYPE)
241 237
242INTERFACE INLINE int 238INTERFACE int
243is_string (pointer p) 239is_string (pointer p)
244{ 240{
245 return type (p) == T_STRING; 241 return type (p) == T_STRING;
246} 242}
247 243
248#define strvalue(p) ((p)->object.string.svalue) 244#define strvalue(p) ((p)->object.string.svalue)
249#define strlength(p) ((p)->object.string.length) 245#define strlength(p) ((p)->object.string.length)
250 246
251INTERFACE int is_list (SCHEME_P_ pointer p); 247INTERFACE int is_list (SCHEME_P_ pointer p);
252 248
253INTERFACE INLINE int 249INTERFACE int
254is_vector (pointer p) 250is_vector (pointer p)
255{ 251{
256 return type (p) == T_VECTOR; 252 return type (p) == T_VECTOR;
257} 253}
258 254
… …
267vector_length (pointer vec) 263vector_length (pointer vec)
268{ 264{
269 return vec->object.vector.length; 265 return vec->object.vector.length;
270} 266}
271 267
272INTERFACE INLINE int 268INTERFACE int
273is_number (pointer p) 269is_number (pointer p)
274{ 270{
275 return type (p) == T_NUMBER; 271 return type (p) == T_NUMBER;
276} 272}
277 273
278INTERFACE INLINE int 274INTERFACE int
279is_integer (pointer p) 275is_integer (pointer p)
280{ 276{
281 if (!is_number (p)) 277 if (!is_number (p))
282 return 0; 278 return 0;
283 279
… …
285 return 1; 281 return 1;
286 282
287 return 0; 283 return 0;
288} 284}
289 285
290INTERFACE INLINE int 286INTERFACE int
291is_real (pointer p) 287is_real (pointer p)
292{ 288{
293 return is_number (p) && !num_is_fixnum (p->object.number); 289 return is_number (p) && !num_is_fixnum (p->object.number);
294} 290}
295 291
296INTERFACE INLINE int 292INTERFACE int
297is_character (pointer p) 293is_character (pointer p)
298{ 294{
299 return type (p) == T_CHARACTER; 295 return type (p) == T_CHARACTER;
300} 296}
301 297
302INTERFACE INLINE char * 298INTERFACE char *
303string_value (pointer p) 299string_value (pointer p)
304{ 300{
305 return strvalue (p); 301 return strvalue (p);
306} 302}
307 303
308INLINE num 304ecb_inline num
309nvalue (pointer p) 305nvalue (pointer p)
310{ 306{
311 return (p)->object.number; 307 return (p)->object.number;
312} 308}
313 309
… …
343#else 339#else
344# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 340# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
345# define set_num_integer(p) 0 341# define set_num_integer(p) 0
346# define set_num_real(p) 0 342# define set_num_real(p) 0
347#endif 343#endif
344
348INTERFACE long 345INTERFACE long
349charvalue (pointer p) 346charvalue (pointer p)
350{ 347{
351 return ivalue_unchecked (p); 348 return ivalue_unchecked (p);
352} 349}
353 350
354INTERFACE INLINE int 351INTERFACE int
355is_port (pointer p) 352is_port (pointer p)
356{ 353{
357 return type (p) == T_PORT; 354 return type (p) == T_PORT;
358} 355}
359 356
360INTERFACE INLINE int 357INTERFACE int
361is_inport (pointer p) 358is_inport (pointer p)
362{ 359{
363 return is_port (p) && p->object.port->kind & port_input; 360 return is_port (p) && p->object.port->kind & port_input;
364} 361}
365 362
366INTERFACE INLINE int 363INTERFACE int
367is_outport (pointer p) 364is_outport (pointer p)
368{ 365{
369 return is_port (p) && p->object.port->kind & port_output; 366 return is_port (p) && p->object.port->kind & port_output;
370} 367}
371 368
372INTERFACE INLINE int 369INTERFACE int
373is_pair (pointer p) 370is_pair (pointer p)
374{ 371{
375 return type (p) == T_PAIR; 372 return type (p) == T_PAIR;
376} 373}
377 374
… …
409pair_cdr (pointer p) 406pair_cdr (pointer p)
410{ 407{
411 return cdr (p); 408 return cdr (p);
412} 409}
413 410
414INTERFACE INLINE int 411INTERFACE int
415is_symbol (pointer p) 412is_symbol (pointer p)
416{ 413{
417 return type (p) == T_SYMBOL; 414 return type (p) == T_SYMBOL;
418} 415}
419 416
420INTERFACE INLINE char * 417INTERFACE char *
421symname (pointer p) 418symname (pointer p)
422{ 419{
423 return strvalue (car (p)); 420 return strvalue (car (p));
424} 421}
425 422
426#if USE_PLIST 423#if USE_PLIST
427SCHEME_EXPORT INLINE int 424SCHEME_EXPORT int
428hasprop (pointer p) 425hasprop (pointer p)
429{ 426{
430 return typeflag (p) & T_SYMBOL; 427 return typeflag (p) & T_SYMBOL;
431} 428}
432 429
433# define symprop(p) cdr(p) 430# define symprop(p) cdr(p)
434#endif 431#endif
435 432
436INTERFACE INLINE int 433INTERFACE int
437is_syntax (pointer p) 434is_syntax (pointer p)
438{ 435{
439 return typeflag (p) & T_SYNTAX; 436 return typeflag (p) & T_SYNTAX;
440} 437}
441 438
442INTERFACE INLINE int 439INTERFACE int
443is_proc (pointer p) 440is_proc (pointer p)
444{ 441{
445 return type (p) == T_PROC; 442 return type (p) == T_PROC;
446} 443}
447 444
448INTERFACE INLINE int 445INTERFACE int
449is_foreign (pointer p) 446is_foreign (pointer p)
450{ 447{
451 return type (p) == T_FOREIGN; 448 return type (p) == T_FOREIGN;
452} 449}
453 450
454INTERFACE INLINE char * 451INTERFACE char *
455syntaxname (pointer p) 452syntaxname (pointer p)
456{ 453{
457 return strvalue (car (p)); 454 return strvalue (car (p));
458} 455}
459 456
460#define procnum(p) ivalue (p) 457#define procnum(p) ivalue (p)
461static const char *procname (pointer x); 458static const char *procname (pointer x);
462 459
463INTERFACE INLINE int 460INTERFACE int
464is_closure (pointer p) 461is_closure (pointer p)
465{ 462{
466 return type (p) == T_CLOSURE; 463 return type (p) == T_CLOSURE;
467} 464}
468 465
469INTERFACE INLINE int 466INTERFACE int
470is_macro (pointer p) 467is_macro (pointer p)
471{ 468{
472 return type (p) == T_MACRO; 469 return type (p) == T_MACRO;
473} 470}
474 471
475INTERFACE INLINE pointer 472INTERFACE pointer
476closure_code (pointer p) 473closure_code (pointer p)
477{ 474{
478 return car (p); 475 return car (p);
479} 476}
480 477
481INTERFACE INLINE pointer 478INTERFACE pointer
482closure_env (pointer p) 479closure_env (pointer p)
483{ 480{
484 return cdr (p); 481 return cdr (p);
485} 482}
486 483
487INTERFACE INLINE int 484INTERFACE int
488is_continuation (pointer p) 485is_continuation (pointer p)
489{ 486{
490 return type (p) == T_CONTINUATION; 487 return type (p) == T_CONTINUATION;
491} 488}
492 489
493#define cont_dump(p) cdr (p) 490#define cont_dump(p) cdr (p)
494#define set_cont_dump(p,v) set_cdr ((p), (v)) 491#define set_cont_dump(p,v) set_cdr ((p), (v))
495 492
496/* To do: promise should be forced ONCE only */ 493/* To do: promise should be forced ONCE only */
497INTERFACE INLINE int 494INTERFACE int
498is_promise (pointer p) 495is_promise (pointer p)
499{ 496{
500 return type (p) == T_PROMISE; 497 return type (p) == T_PROMISE;
501} 498}
502 499
503INTERFACE INLINE int 500INTERFACE int
504is_environment (pointer p) 501is_environment (pointer p)
505{ 502{
506 return type (p) == T_ENVIRONMENT; 503 return type (p) == T_ENVIRONMENT;
507} 504}
508 505
… …
514 511
515#define is_mark(p) (typeflag (p) & T_MARK) 512#define is_mark(p) (typeflag (p) & T_MARK)
516#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 513#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
517#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 514#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518 515
519INTERFACE INLINE int 516INTERFACE int
520is_immutable (pointer p) 517is_immutable (pointer p)
521{ 518{
522 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 519 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523} 520}
524 521
525INTERFACE INLINE void 522INTERFACE void
526setimmutable (pointer p) 523setimmutable (pointer p)
527{ 524{
528#if USE_ERROR_CHECKING 525#if USE_ERROR_CHECKING
529 set_typeflag (p, typeflag (p) | T_IMMUTABLE); 526 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
530#endif 527#endif
531} 528}
532 529
533#if USE_CHAR_CLASSIFIERS 530#if USE_CHAR_CLASSIFIERS
534static INLINE int 531ecb_inline int
535Cisalpha (int c) 532Cisalpha (int c)
536{ 533{
537 return isascii (c) && isalpha (c); 534 return isascii (c) && isalpha (c);
538} 535}
539 536
540static INLINE int 537ecb_inline int
541Cisdigit (int c) 538Cisdigit (int c)
542{ 539{
543 return isascii (c) && isdigit (c); 540 return isascii (c) && isdigit (c);
544} 541}
545 542
546static INLINE int 543ecb_inline int
547Cisspace (int c) 544Cisspace (int c)
548{ 545{
549 return isascii (c) && isspace (c); 546 return isascii (c) && isspace (c);
550} 547}
551 548
552static INLINE int 549ecb_inline int
553Cisupper (int c) 550Cisupper (int c)
554{ 551{
555 return isascii (c) && isupper (c); 552 return isascii (c) && isupper (c);
556} 553}
557 554
558static INLINE int 555ecb_inline int
559Cislower (int c) 556Cislower (int c)
560{ 557{
561 return isascii (c) && islower (c); 558 return isascii (c) && islower (c);
562} 559}
563#endif 560#endif
… …
624#endif 621#endif
625 622
626static int file_push (SCHEME_P_ const char *fname); 623static int file_push (SCHEME_P_ const char *fname);
627static void file_pop (SCHEME_P); 624static void file_pop (SCHEME_P);
628static int file_interactive (SCHEME_P); 625static int file_interactive (SCHEME_P);
629static INLINE int is_one_of (char *s, int c); 626ecb_inline int is_one_of (char *s, int c);
630static int alloc_cellseg (SCHEME_P_ int n); 627static int alloc_cellseg (SCHEME_P_ int n);
631static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 628ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632static void finalize_cell (SCHEME_P_ pointer a); 629static void finalize_cell (SCHEME_P_ pointer a);
633static int count_consecutive_cells (pointer x, int needed); 630static int count_consecutive_cells (pointer x, int needed);
634static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 631static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
635static pointer mk_number (SCHEME_P_ const num n); 632static pointer mk_number (SCHEME_P_ const num n);
636static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 633static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
… …
653static int basic_inchar (port *pt); 650static int basic_inchar (port *pt);
654static int inchar (SCHEME_P); 651static int inchar (SCHEME_P);
655static void backchar (SCHEME_P_ int c); 652static void backchar (SCHEME_P_ int c);
656static char *readstr_upto (SCHEME_P_ char *delim); 653static char *readstr_upto (SCHEME_P_ char *delim);
657static pointer readstrexp (SCHEME_P); 654static pointer readstrexp (SCHEME_P);
658static INLINE int skipspace (SCHEME_P); 655ecb_inline int skipspace (SCHEME_P);
659static int token (SCHEME_P); 656static int token (SCHEME_P);
660static void printslashstring (SCHEME_P_ char *s, int len); 657static void printslashstring (SCHEME_P_ char *s, int len);
661static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 658static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
662static void printatom (SCHEME_P_ pointer l, int f); 659static void printatom (SCHEME_P_ pointer l, int f);
663static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 660static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
781 778
782 num_set_ivalue (ret, res); 779 num_set_ivalue (ret, res);
783 return ret; 780 return ret;
784} 781}
785 782
786/* this completely disrespects NaNs */ 783/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787static int 784static int
788num_cmp (num a, num b) 785num_cmp (num a, num b)
789{ 786{
790 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 787 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791 int ret; 788 int ret;
… …
834#endif 831#endif
835 832
836static int 833static int
837is_zero_rvalue (RVALUE x) 834is_zero_rvalue (RVALUE x)
838{ 835{
836 return x == 0;
837#if 0
839#if USE_REAL 838#if USE_REAL
840 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 839 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
841#else 840#else
842 return x == 0; 841 return x == 0;
842#endif
843#endif 843#endif
844} 844}
845 845
846/* allocate new cell segment */ 846/* allocate new cell segment */
847static int 847static int
… …
919 919
920 return n; 920 return n;
921} 921}
922 922
923/* get new cell. parameter a, b is marked by gc. */ 923/* get new cell. parameter a, b is marked by gc. */
924static INLINE pointer 924ecb_inline pointer
925get_cell_x (SCHEME_P_ pointer a, pointer b) 925get_cell_x (SCHEME_P_ pointer a, pointer b)
926{ 926{
927 if (ecb_expect_false (SCHEME_V->free_cell == NIL)) 927 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928 { 928 {
929 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 929 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
… …
1007 push_recent_alloc (SCHEME_A_ v, NIL); 1007 push_recent_alloc (SCHEME_A_ v, NIL);
1008 1008
1009 return v; 1009 return v;
1010} 1010}
1011 1011
1012static INLINE void 1012ecb_inline void
1013ok_to_freely_gc (SCHEME_P) 1013ok_to_freely_gc (SCHEME_P)
1014{ 1014{
1015 set_car (S_SINK, NIL); 1015 set_car (S_SINK, NIL);
1016} 1016}
1017 1017
… …
1081 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1081 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))); 1082 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1083 return x; 1083 return x;
1084} 1084}
1085 1085
1086static INLINE pointer 1086ecb_inline pointer
1087oblist_find_by_name (SCHEME_P_ const char *name) 1087oblist_find_by_name (SCHEME_P_ const char *name)
1088{ 1088{
1089 int location; 1089 int location;
1090 pointer x; 1090 pointer x;
1091 char *s; 1091 char *s;
… …
1124oblist_initial_value (SCHEME_P) 1124oblist_initial_value (SCHEME_P)
1125{ 1125{
1126 return NIL; 1126 return NIL;
1127} 1127}
1128 1128
1129static INLINE pointer 1129ecb_inline pointer
1130oblist_find_by_name (SCHEME_P_ const char *name) 1130oblist_find_by_name (SCHEME_P_ const char *name)
1131{ 1131{
1132 pointer x; 1132 pointer x;
1133 char *s; 1133 char *s;
1134 1134
… …
2232 } 2232 }
2233 } 2233 }
2234} 2234}
2235 2235
2236/* check c is in chars */ 2236/* check c is in chars */
2237static INLINE int 2237ecb_inline int
2238is_one_of (char *s, int c) 2238is_one_of (char *s, int c)
2239{ 2239{
2240 if (c == EOF) 2240 if (c == EOF)
2241 return 1; 2241 return 1;
2242 2242
2243 return !!strchr (s, c); 2243 return !!strchr (s, c);
2244} 2244}
2245 2245
2246/* skip white characters */ 2246/* skip white characters */
2247static INLINE int 2247ecb_inline int
2248skipspace (SCHEME_P) 2248skipspace (SCHEME_P)
2249{ 2249{
2250 int c, curr_line = 0; 2250 int c, curr_line = 0;
2251 2251
2252 do 2252 do
… …
2823 2823
2824 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2824 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825 setenvironment (SCHEME_V->envir); 2825 setenvironment (SCHEME_V->envir);
2826} 2826}
2827 2827
2828static INLINE void 2828ecb_inline void
2829new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2829new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830{ 2830{
2831 pointer slot = immutable_cons (variable, value); 2831 pointer slot = immutable_cons (variable, value);
2832 2832
2833 if (is_vector (car (env))) 2833 if (is_vector (car (env)))
… …
2873 return NIL; 2873 return NIL;
2874} 2874}
2875 2875
2876#else /* USE_ALIST_ENV */ 2876#else /* USE_ALIST_ENV */
2877 2877
2878static INLINE void 2878ecb_inline void
2879new_frame_in_env (SCHEME_P_ pointer old_env) 2879new_frame_in_env (SCHEME_P_ pointer old_env)
2880{ 2880{
2881 SCHEME_V->envir = immutable_cons (NIL, old_env); 2881 SCHEME_V->envir = immutable_cons (NIL, old_env);
2882 setenvironment (SCHEME_V->envir); 2882 setenvironment (SCHEME_V->envir);
2883} 2883}
2884 2884
2885static INLINE void 2885ecb_inline void
2886new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2886new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887{ 2887{
2888 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2888 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889} 2889}
2890 2890
… …
2912 return NIL; 2912 return NIL;
2913} 2913}
2914 2914
2915#endif /* USE_ALIST_ENV else */ 2915#endif /* USE_ALIST_ENV else */
2916 2916
2917static INLINE void 2917ecb_inline void
2918new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2918new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919{ 2919{
2920 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2920 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921} 2921}
2922 2922
2923static INLINE void 2923ecb_inline void
2924set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2924set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925{ 2925{
2926 set_cdr (slot, value); 2926 set_cdr (slot, value);
2927} 2927}
2928 2928
2929static INLINE pointer 2929ecb_inline pointer
2930slot_value_in_env (pointer slot) 2930slot_value_in_env (pointer slot)
2931{ 2931{
2932 return cdr (slot); 2932 return cdr (slot);
2933} 2933}
2934 2934
… …
3062 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3062 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063 3063
3064 return 0; 3064 return 0;
3065} 3065}
3066 3066
3067static INLINE void 3067ecb_inline void
3068dump_stack_reset (SCHEME_P) 3068dump_stack_reset (SCHEME_P)
3069{ 3069{
3070 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3070 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071 SCHEME_V->dump = (pointer)+0; 3071 SCHEME_V->dump = (pointer)+0;
3072} 3072}
3073 3073
3074static INLINE void 3074ecb_inline void
3075dump_stack_initialize (SCHEME_P) 3075dump_stack_initialize (SCHEME_P)
3076{ 3076{
3077 SCHEME_V->dump_size = 0; 3077 SCHEME_V->dump_size = 0;
3078 SCHEME_V->dump_base = 0; 3078 SCHEME_V->dump_base = 0;
3079 dump_stack_reset (SCHEME_A); 3079 dump_stack_reset (SCHEME_A);
… …
3146 SCHEME_V->dump = (pointer)(uintptr_t)i; 3146 SCHEME_V->dump = (pointer)(uintptr_t)i;
3147} 3147}
3148 3148
3149#else 3149#else
3150 3150
3151static INLINE void 3151ecb_inline void
3152dump_stack_reset (SCHEME_P) 3152dump_stack_reset (SCHEME_P)
3153{ 3153{
3154 SCHEME_V->dump = NIL; 3154 SCHEME_V->dump = NIL;
3155} 3155}
3156 3156
3157static INLINE void 3157ecb_inline void
3158dump_stack_initialize (SCHEME_P) 3158dump_stack_initialize (SCHEME_P)
3159{ 3159{
3160 dump_stack_reset (SCHEME_A); 3160 dump_stack_reset (SCHEME_A);
3161} 3161}
3162 3162
… …
4015 4015
4016 case OP_ADD: /* + */ 4016 case OP_ADD: /* + */
4017 v = num_zero; 4017 v = num_zero;
4018 4018
4019 for (x = args; x != NIL; x = cdr (x)) 4019 for (x = args; x != NIL; x = cdr (x))
4020 v = num_op ('+', v, nvalue (car (x))); 4020 v = num_op (NUM_ADD, v, nvalue (car (x)));
4021 4021
4022 s_return (mk_number (SCHEME_A_ v)); 4022 s_return (mk_number (SCHEME_A_ v));
4023 4023
4024 case OP_MUL: /* * */ 4024 case OP_MUL: /* * */
4025 v = num_one; 4025 v = num_one;
4026 4026
4027 for (x = args; x != NIL; x = cdr (x)) 4027 for (x = args; x != NIL; x = cdr (x))
4028 v = num_op ('*', v, nvalue (car (x))); 4028 v = num_op (NUM_MUL, v, nvalue (car (x)));
4029 4029
4030 s_return (mk_number (SCHEME_A_ v)); 4030 s_return (mk_number (SCHEME_A_ v));
4031 4031
4032 case OP_SUB: /* - */ 4032 case OP_SUB: /* - */
4033 if (cdr (args) == NIL) 4033 if (cdr (args) == NIL)
… …
4040 x = cdr (args); 4040 x = cdr (args);
4041 v = nvalue (car (args)); 4041 v = nvalue (car (args));
4042 } 4042 }
4043 4043
4044 for (; x != NIL; x = cdr (x)) 4044 for (; x != NIL; x = cdr (x))
4045 v = num_op ('-', v, nvalue (car (x))); 4045 v = num_op (NUM_SUB, v, nvalue (car (x)));
4046 4046
4047 s_return (mk_number (SCHEME_A_ v)); 4047 s_return (mk_number (SCHEME_A_ v));
4048 4048
4049 case OP_DIV: /* / */ 4049 case OP_DIV: /* / */
4050 if (cdr (args) == NIL) 4050 if (cdr (args) == NIL)
… …
4057 x = cdr (args); 4057 x = cdr (args);
4058 v = nvalue (car (args)); 4058 v = nvalue (car (args));
4059 } 4059 }
4060 4060
4061 for (; x != NIL; x = cdr (x)) 4061 for (; x != NIL; x = cdr (x))
4062 {
4063 if (!is_zero_rvalue (rvalue (car (x)))) 4062 if (!is_zero_rvalue (rvalue (car (x))))
4064 v = num_div (v, nvalue (car (x))); 4063 v = num_div (v, nvalue (car (x)));
4065 else 4064 else
4066 Error_0 ("/: division by zero"); 4065 Error_0 ("/: division by zero");
4067 }
4068 4066
4069 s_return (mk_number (SCHEME_A_ v)); 4067 s_return (mk_number (SCHEME_A_ v));
4070 4068
4071 case OP_INTDIV: /* quotient */ 4069 case OP_INTDIV: /* quotient */
4072 if (cdr (args) == NIL) 4070 if (cdr (args) == NIL)
… …
4081 } 4079 }
4082 4080
4083 for (; x != NIL; x = cdr (x)) 4081 for (; x != NIL; x = cdr (x))
4084 { 4082 {
4085 if (ivalue (car (x)) != 0) 4083 if (ivalue (car (x)) != 0)
4086 v = num_op ('/', v, nvalue (car (x))); 4084 v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087 else 4085 else
4088 Error_0 ("quotient: division by zero"); 4086 Error_0 ("quotient: division by zero");
4089 } 4087 }
4090 4088
4091 s_return (mk_number (SCHEME_A_ v)); 4089 s_return (mk_number (SCHEME_A_ v));
… …
4783 break; 4781 break;
4784 } 4782 }
4785 4783
4786 p = port_from_filename (SCHEME_A_ strvalue (a), prop); 4784 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787 4785
4788 if (p == NIL) 4786 s_return (p == NIL ? S_F : p);
4789 s_return (S_F);
4790
4791 s_return (p);
4792 } 4787 }
4793 4788
4794# if USE_STRING_PORTS 4789# if USE_STRING_PORTS
4795 4790
4796 case OP_OPEN_INSTRING: /* open-input-string */ 4791 case OP_OPEN_INSTRING: /* open-input-string */
… …
4811 } 4806 }
4812 4807
4813 p = port_from_string (SCHEME_A_ strvalue (a), 4808 p = port_from_string (SCHEME_A_ strvalue (a),
4814 strvalue (a) + strlength (a), prop); 4809 strvalue (a) + strlength (a), prop);
4815 4810
4816 if (p == NIL) 4811 s_return (p == NIL ? S_F : p);
4817 s_return (S_F);
4818
4819 s_return (p);
4820 } 4812 }
4821 4813
4822 case OP_OPEN_OUTSTRING: /* open-output-string */ 4814 case OP_OPEN_OUTSTRING: /* open-output-string */
4823 { 4815 {
4824 pointer p; 4816 pointer p;
4825 4817
4826 if (a == NIL) 4818 if (a == NIL)
4827 {
4828 p = port_from_scratch (SCHEME_A); 4819 p = port_from_scratch (SCHEME_A);
4829
4830 if (p == NIL)
4831 s_return (S_F);
4832 }
4833 else 4820 else
4834 {
4835 p = port_from_string (SCHEME_A_ strvalue (a), 4821 p = port_from_string (SCHEME_A_ strvalue (a),
4836 strvalue (a) + strlength (a), port_output); 4822 strvalue (a) + strlength (a), port_output);
4837 4823
4838 if (p == NIL) 4824 s_return (p == NIL ? S_F : p);
4839 s_return (S_F);
4840 }
4841
4842 s_return (p);
4843 } 4825 }
4844 4826
4845 case OP_GET_OUTSTRING: /* get-output-string */ 4827 case OP_GET_OUTSTRING: /* get-output-string */
4846 { 4828 {
4847 port *p; 4829 port *p;
… …
5401#undef OP_DEF 5383#undef OP_DEF
5402 {0} 5384 {0}
5403}; 5385};
5404 5386
5405/* kernel of this interpreter */ 5387/* kernel of this interpreter */
5406static void 5388static void ecb_hot
5407Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5389Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408{ 5390{
5409 SCHEME_V->op = op; 5391 SCHEME_V->op = op;
5410 5392
5411 for (;;) 5393 for (;;)
… …
5589 return OP_C0STREAM; /* cons-stream */ 5571 return OP_C0STREAM; /* cons-stream */
5590 } 5572 }
5591} 5573}
5592 5574
5593#if USE_MULTIPLICITY 5575#if USE_MULTIPLICITY
5594scheme * 5576ecb_cold scheme *
5595scheme_init_new () 5577scheme_init_new ()
5596{ 5578{
5597 scheme *sc = malloc (sizeof (scheme)); 5579 scheme *sc = malloc (sizeof (scheme));
5598 5580
5599 if (!scheme_init (SCHEME_A)) 5581 if (!scheme_init (SCHEME_A))
… …
5604 else 5586 else
5605 return sc; 5587 return sc;
5606} 5588}
5607#endif 5589#endif
5608 5590
5609int 5591ecb_cold int
5610scheme_init (SCHEME_P) 5592scheme_init (SCHEME_P)
5611{ 5593{
5612 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5594 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5613 pointer x; 5595 pointer x;
5614 5596
… …
5739scheme_set_external_data (SCHEME_P_ void *p) 5721scheme_set_external_data (SCHEME_P_ void *p)
5740{ 5722{
5741 SCHEME_V->ext_data = p; 5723 SCHEME_V->ext_data = p;
5742} 5724}
5743 5725
5744void 5726ecb_cold void
5745scheme_deinit (SCHEME_P) 5727scheme_deinit (SCHEME_P)
5746{ 5728{
5747 int i; 5729 int i;
5748 5730
5749#if SHOW_ERROR_LINE 5731#if SHOW_ERROR_LINE

Diff Legend

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