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.66 by root, Mon Dec 7 18:10:57 2015 UTC vs.
Revision 1.70 by root, Mon Dec 7 22:13:31 2015 UTC

… …
329string_value (pointer p) 329string_value (pointer p)
330{ 330{
331 return strvalue (p); 331 return strvalue (p);
332} 332}
333 333
334#define ivalue_unchecked(p) CELL(p)->object.ivalue 334#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
336 336
337#if USE_REAL 337#if USE_REAL
338#define rvalue_unchecked(p) CELL(p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
… …
1259 if (!*pp) 1259 if (!*pp)
1260 { 1260 {
1261 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1261 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1262 1262
1263 set_typeflag (x, T_INTEGER | T_ATOM); 1263 set_typeflag (x, T_INTEGER | T_ATOM);
1264 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ 1264 setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1265 set_ivalue (x, n); 1265 set_ivalue (x, n);
1266 1266
1267 *pp = x; 1267 *pp = x;
1268 } 1268 }
1269 1269
… …
1546 return mk_character (SCHEME_A_ c); 1546 return mk_character (SCHEME_A_ c);
1547 } 1547 }
1548 else 1548 else
1549 { 1549 {
1550 /* identify base by string index */ 1550 /* identify base by string index */
1551 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; 1551 const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1552 char *base = strchr (baseidx, *name); 1552 char *base = strchr (baseidx, *name);
1553 1553
1554 if (base) 1554 if (base && *base)
1555 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); 1555 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1556 1556
1557 return NIL; 1557 return NIL;
1558 } 1558 }
1559} 1559}
… …
2613 } 2613 }
2614 else if (is_symbol (l)) 2614 else if (is_symbol (l))
2615 p = symname (l); 2615 p = symname (l);
2616 else if (is_proc (l)) 2616 else if (is_proc (l))
2617 { 2617 {
2618 p = (char *)procname (l); // ok with r7rs display, but not r7rs write
2619#if 0
2618#if USE_PRINTF 2620#if USE_PRINTF
2619 p = SCHEME_V->strbuff; 2621 p = SCHEME_V->strbuff;
2620 snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l)); 2622 snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2621#else 2623#else
2622 p = "#<PROCEDURE>"; 2624 p = "#<PROCEDURE>";
2625#endif
2623#endif 2626#endif
2624 } 2627 }
2625 else if (is_macro (l)) 2628 else if (is_macro (l))
2626 p = "#<MACRO>"; 2629 p = "#<MACRO>";
2627 else if (is_closure (l)) 2630 else if (is_closure (l))
… …
2817{ 2820{
2818 pointer new_frame; 2821 pointer new_frame;
2819 2822
2820 /* The interaction-environment has about 300 variables in it. */ 2823 /* The interaction-environment has about 300 variables in it. */
2821 if (old_env == NIL) 2824 if (old_env == NIL)
2822 new_frame = mk_vector (SCHEME_A_ 461); 2825 new_frame = mk_vector (SCHEME_A_ 29); // was 461
2823 else 2826 else
2824 new_frame = NIL; 2827 new_frame = NIL;
2825 2828
2826 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2829 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2827 setenvironment (SCHEME_V->envir); 2830 setenvironment (SCHEME_V->envir);
… …
3391 BOP_DEFINE, 3394 BOP_DEFINE,
3392 BOP_MACRO, 3395 BOP_MACRO,
3393 BOP_SET, 3396 BOP_SET,
3394 BOP_BEGIN, 3397 BOP_BEGIN,
3395 BOP_LAMBDA, 3398 BOP_LAMBDA,
3399 BOP_DELAY,
3396 BOP_OP, 3400 BOP_OP,
3397}; 3401};
3398 3402
3399ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x); 3403ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3400 3404
… …
3519 { 3523 {
3520 pointer head = car (x); 3524 pointer head = car (x);
3521 3525
3522 if (is_syntax (head)) 3526 if (is_syntax (head))
3523 { 3527 {
3528 int syn = syntaxnum (head);
3524 x = cdr (x); 3529 x = cdr (x);
3525 3530
3526 switch (syntaxnum (head)) 3531 switch (syntaxnum (head))
3527 { 3532 {
3528 case OP_IF0: /* if */ 3533 case OP_IF0: /* if */
… …
3551 break; 3556 break;
3552 3557
3553 case OP_LET0: /* let */ 3558 case OP_LET0: /* let */
3554 case OP_LET0AST: /* let* */ 3559 case OP_LET0AST: /* let* */
3555 case OP_LET0REC: /* letrec */ 3560 case OP_LET0REC: /* letrec */
3556 switch (syntaxnum (head)) 3561 switch (syn)
3557 { 3562 {
3558 case OP_LET0: stream_put (s, BOP_LET ); break; 3563 case OP_LET0: stream_put (s, BOP_LET ); break;
3559 case OP_LET0AST: stream_put (s, BOP_LETAST); break; 3564 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3560 case OP_LET0REC: stream_put (s, BOP_LETREC); break; 3565 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3561 } 3566 }
… …
3600 case OP_BEGIN: /* begin */ 3605 case OP_BEGIN: /* begin */
3601 stream_put (s, BOP_BEGIN); 3606 stream_put (s, BOP_BEGIN);
3602 compile_list (SCHEME_A_ s, x); 3607 compile_list (SCHEME_A_ s, x);
3603 return; 3608 return;
3604 3609
3605 case OP_DELAY: /* delay */
3606 abort ();
3607 break;
3608
3609 case OP_QUOTE: /* quote */ 3610 case OP_QUOTE: /* quote */
3610 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x)); 3611 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3612 break;
3613
3614 case OP_DELAY: /* delay */
3615 stream_put (s, BOP_DELAY);
3616 compile_expr (SCHEME_A_ s, x);
3611 break; 3617 break;
3612 3618
3613 case OP_LAMBDA: /* lambda */ 3619 case OP_LAMBDA: /* lambda */
3614 { 3620 {
3615 pointer formals = car (x); 3621 pointer formals = car (x);
… …
3917 3923
3918 case OP_REAL_APPLY: 3924 case OP_REAL_APPLY:
3919#endif 3925#endif
3920 if (is_proc (SCHEME_V->code)) 3926 if (is_proc (SCHEME_V->code))
3921 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3927 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3922 else if (is_foreign (SCHEME_V->code))
3923 {
3924 /* Keep nested calls from GC'ing the arglist */
3925 push_recent_alloc (SCHEME_A_ args, NIL);
3926 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3927
3928 s_return (x);
3929 }
3930 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3928 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3931 { 3929 {
3932 /* Should not accept promise */ 3930 /* Should not accept promise */
3933 /* make environment */ 3931 /* make environment */
3934 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); 3932 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
… …
3960 } 3958 }
3961 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3959 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3962 { 3960 {
3963 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3961 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3964 s_return (args != NIL ? car (args) : NIL); 3962 s_return (args != NIL ? car (args) : NIL);
3963 }
3964 else if (is_foreign (SCHEME_V->code))
3965 {
3966 /* Keep nested calls from GC'ing the arglist */
3967 push_recent_alloc (SCHEME_A_ args, NIL);
3968 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3969
3970 s_return (x);
3965 } 3971 }
3966 3972
3967 Error_0 ("illegal function"); 3973 Error_0 ("illegal function");
3968 3974
3969 case OP_DOMACRO: /* do macro */ 3975 case OP_DOMACRO: /* do macro */
… …
5597 s_return (S_T); 5603 s_return (S_T);
5598 } 5604 }
5599 5605
5600 case OP_PVECFROM: 5606 case OP_PVECFROM:
5601 { 5607 {
5602 int i = ivalue_unchecked (cdr (args)); 5608 IVALUE i = ivalue_unchecked (cdr (args));
5603 pointer vec = car (args); 5609 pointer vec = car (args);
5604 int len = veclength (vec); 5610 uint32_t len = veclength (vec);
5605 5611
5606 if (i == len) 5612 if (i == len)
5607 { 5613 {
5608 putcharacter (SCHEME_A_ ')'); 5614 putcharacter (SCHEME_A_ ')');
5609 s_return (S_T); 5615 s_return (S_T);
5610 } 5616 }
5611 else 5617 else
5612 { 5618 {
5613 pointer elem = vector_get (vec, i); 5619 pointer elem = vector_get (vec, i);
5614 5620
5615 ivalue_unchecked (cdr (args)) = i + 1; 5621 set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5616 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5622 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5617 SCHEME_V->args = elem; 5623 SCHEME_V->args = elem;
5618 5624
5619 if (i > 0) 5625 if (i > 0)
5620 putcharacter (SCHEME_A_ ' '); 5626 putcharacter (SCHEME_A_ ' ');
… …
5920static pointer 5926static pointer
5921mk_proc (SCHEME_P_ enum scheme_opcodes op) 5927mk_proc (SCHEME_P_ enum scheme_opcodes op)
5922{ 5928{
5923 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5929 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5924 set_typeflag (y, (T_PROC | T_ATOM)); 5930 set_typeflag (y, (T_PROC | T_ATOM));
5925 ivalue_unchecked (y) = op; 5931 set_ivalue (y, op);
5926 return y; 5932 return y;
5927} 5933}
5928 5934
5929/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5935/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5930ecb_hot static int 5936ecb_hot static int

Diff Legend

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