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.68 by root, Mon Dec 7 21:12:56 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))
… …
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));
3611 break; 3612 break;
3612 3613
3614 case OP_DELAY: /* delay */
3613 case OP_LAMBDA: /* lambda */ 3615 case OP_LAMBDA: /* lambda */
3614 { 3616 {
3615 pointer formals = car (x); 3617 pointer formals = car (x);
3616 pointer body = cadr (x); 3618 pointer body = cadr (x);
3617 3619
3618 stream_put (s, BOP_LAMBDA); 3620 stream_put (s, syn == OP_LAMBDA ? BOP_LAMBDA : BOP_DELAY);
3619 3621
3620 for (; is_pair (formals); formals = cdr (formals)) 3622 for (; is_pair (formals); formals = cdr (formals))
3621 stream_put_v (s, symbol_id (SCHEME_A_ car (formals))); 3623 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3622 3624
3623 stream_put_v (s, 0); 3625 stream_put_v (s, 0);
… …
5597 s_return (S_T); 5599 s_return (S_T);
5598 } 5600 }
5599 5601
5600 case OP_PVECFROM: 5602 case OP_PVECFROM:
5601 { 5603 {
5602 int i = ivalue_unchecked (cdr (args)); 5604 IVALUE i = ivalue_unchecked (cdr (args));
5603 pointer vec = car (args); 5605 pointer vec = car (args);
5604 int len = veclength (vec); 5606 uint32_t len = veclength (vec);
5605 5607
5606 if (i == len) 5608 if (i == len)
5607 { 5609 {
5608 putcharacter (SCHEME_A_ ')'); 5610 putcharacter (SCHEME_A_ ')');
5609 s_return (S_T); 5611 s_return (S_T);
5610 } 5612 }
5611 else 5613 else
5612 { 5614 {
5613 pointer elem = vector_get (vec, i); 5615 pointer elem = vector_get (vec, i);
5614 5616
5615 ivalue_unchecked (cdr (args)) = i + 1; 5617 set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5616 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5618 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5617 SCHEME_V->args = elem; 5619 SCHEME_V->args = elem;
5618 5620
5619 if (i > 0) 5621 if (i > 0)
5620 putcharacter (SCHEME_A_ ' '); 5622 putcharacter (SCHEME_A_ ' ');
… …
5920static pointer 5922static pointer
5921mk_proc (SCHEME_P_ enum scheme_opcodes op) 5923mk_proc (SCHEME_P_ enum scheme_opcodes op)
5922{ 5924{
5923 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5925 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5924 set_typeflag (y, (T_PROC | T_ATOM)); 5926 set_typeflag (y, (T_PROC | T_ATOM));
5925 ivalue_unchecked (y) = op; 5927 set_ivalue (y, op);
5926 return y; 5928 return y;
5927} 5929}
5928 5930
5929/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5931/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5930ecb_hot static int 5932ecb_hot static int

Diff Legend

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