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.63 by root, Wed Dec 2 12:16:24 2015 UTC vs.
Revision 1.64 by root, Wed Dec 2 17:01:18 2015 UTC

… …
383static pointer cddr (pointer p) { return cdr (cdr (p)); } 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
384 384
385static pointer cadar (pointer p) { return car (cdr (car (p))); } 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
386static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
387static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
388
389static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
388 390
389INTERFACE void 391INTERFACE void
390set_car (pointer p, pointer q) 392set_car (pointer p, pointer q)
391{ 393{
392 CELL(p)->object.cons.car = CELL (q); 394 CELL(p)->object.cons.car = CELL (q);
… …
2937/* ========== Evaluation Cycle ========== */ 2939/* ========== Evaluation Cycle ========== */
2938 2940
2939ecb_cold static int 2941ecb_cold static int
2940xError_1 (SCHEME_P_ const char *s, pointer a) 2942xError_1 (SCHEME_P_ const char *s, pointer a)
2941{ 2943{
2942#if USE_ERROR_HOOK
2943 pointer x;
2944 pointer hdl = SCHEME_V->ERROR_HOOK;
2945#endif
2946
2947#if USE_PRINTF 2944#if USE_PRINTF
2948#if SHOW_ERROR_LINE 2945#if SHOW_ERROR_LINE
2949 char sbuf[STRBUFFSIZE]; 2946 char sbuf[STRBUFFSIZE];
2950 2947
2951 /* make sure error is not in REPL */ 2948 /* make sure error is not in REPL */
… …
2966 } 2963 }
2967#endif 2964#endif
2968#endif 2965#endif
2969 2966
2970#if USE_ERROR_HOOK 2967#if USE_ERROR_HOOK
2971 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2968 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
2972 2969
2973 if (x != NIL) 2970 if (x != NIL)
2974 { 2971 {
2975 pointer code = a 2972 pointer code = a
2976 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2973 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3220 3217
3221#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3218#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3222 3219
3223#if EXPERIMENT 3220#if EXPERIMENT
3224 3221
3225typedef void *stream[1];
3226
3227#define stream_init() { 0 }
3228
3229ecb_cold static void
3230stream_put (void **s, uint8_t byte)
3231{
3232 uint32_t *sp = *s;
3233 uint32_t size = sizeof (uint32_t) * 2;
3234 uint32_t offs = size;
3235
3236 if (ecb_expect_true (sp))
3237 {
3238 offs = sp[0];
3239 size = sp[1];
3240 }
3241
3242 if (ecb_expect_false (offs == size))
3243 {
3244 size *= 2;
3245 sp = realloc (sp, size);
3246 *s = sp;
3247 sp[1] = size;
3248
3249 }
3250
3251 ((uint8_t *)sp)[offs++] = byte;
3252 sp[0] = offs;
3253}
3254
3255#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3256#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3257#define stream_free(s) free (s[0])
3258
3259// calculates a (preferably small) integer that makes it possible to find
3260// the symbol again. if pointers were offsets into a memory area... until
3261// then, we return segment number in the low bits, and offset in the high
3262// bits
3263static uint32_t
3264symbol_id (SCHEME_P_ pointer sym)
3265{
3266 struct cell *p = CELL (sym);
3267 int i;
3268
3269 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3270 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3271 {
3272 printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
3273 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3274 }
3275
3276 abort ();
3277}
3278
3279static void
3280compile (SCHEME_P_ stream s, pointer x)
3281{
3282 if (x == NIL)
3283 {
3284 stream_put (s, 0);
3285 return;
3286 }
3287
3288 if (is_syntax (x))
3289 {
3290 stream_put (s, 1);
3291 stream_put (s, syntaxnum (x));
3292 return;
3293 }
3294
3295 switch (type (x))
3296 {
3297 case T_INTEGER:
3298 stream_put (s, 2);
3299 stream_put (s, 0);
3300 stream_put (s, 0);
3301 stream_put (s, 0);
3302 stream_put (s, 0);
3303 return;
3304
3305 case T_SYMBOL:
3306 {
3307 uint32_t sym = symbol_id (SCHEME_A_ x);
3308 printf ("sym %x\n", sym);//D
3309
3310 stream_put (s, 3);
3311
3312 while (sym > 0x7f)
3313 {
3314 stream_put (s, sym | 0x80);
3315 sym >>= 8;
3316 }
3317
3318 stream_put (s, sym);
3319 }
3320 return;
3321
3322 case T_PAIR:
3323 stream_put (s, 4);
3324 while (x != NIL)
3325 {
3326 compile (SCHEME_A_ s, car (x));
3327 x = cdr (x);
3328 }
3329 stream_put (s, 0xff);
3330 return;
3331
3332 default:
3333 stream_put (s, 5);
3334 stream_put (s, type (x));
3335 stream_put (s, 0);
3336 stream_put (s, 0);
3337 stream_put (s, 0);
3338 stream_put (s, 0);
3339 break;
3340 }
3341}
3342
3343static int
3344compile_closure (SCHEME_P_ pointer p)
3345{
3346 stream s = stream_init ();
3347
3348 printatom (SCHEME_A_ p, 1);//D
3349 compile (SCHEME_A_ s, car (p));
3350
3351 FILE *xxd = popen ("xxd", "we");
3352 fwrite (stream_data (s), 1, stream_size (s), xxd);
3353 fclose (xxd);
3354
3355 return stream_size (s);
3356}
3357
3358static int 3222static int
3359dtree (SCHEME_P_ int indent, pointer x) 3223dtree (SCHEME_P_ int indent, pointer x)
3360{ 3224{
3361 int c; 3225 int c;
3362 3226
… …
3408 default: 3272 default:
3409 printf ("unhandled type %d\n", type (x)); 3273 printf ("unhandled type %d\n", type (x));
3410 break; 3274 break;
3411 } 3275 }
3412} 3276}
3277
3278#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3279
3280typedef void *stream[1];
3281
3282#define stream_init() { 0 }
3283#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3284#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3285#define stream_free(s) free (s[0])
3286
3287ecb_cold static void
3288stream_put (stream s, uint8_t byte)
3289{
3290 uint32_t *sp = *s;
3291 uint32_t size = sizeof (uint32_t) * 2;
3292 uint32_t offs = size;
3293
3294 if (ecb_expect_true (sp))
3295 {
3296 offs = sp[0];
3297 size = sp[1];
3298 }
3299
3300 if (ecb_expect_false (offs == size))
3301 {
3302 size *= 2;
3303 sp = realloc (sp, size);
3304 *s = sp;
3305 sp[1] = size;
3306
3307 }
3308
3309 ((uint8_t *)sp)[offs++] = byte;
3310 sp[0] = offs;
3311}
3312
3313ecb_cold static void
3314stream_put_v (stream s, uint32_t v)
3315{
3316 while (v > 0x7f)
3317 {
3318 stream_put (s, v | 0x80);
3319 v >>= 7;
3320 }
3321
3322 stream_put (s, v);
3323}
3324
3325ecb_cold static void
3326stream_put_tv (stream s, int bop, uint32_t v)
3327{
3328 printf ("put tv %d %d\n", bop, v);//D
3329 stream_put (s, bop);
3330 stream_put_v (s, v);
3331}
3332
3333ecb_cold static void
3334stream_put_stream (stream s, stream o)
3335{
3336 uint32_t i;
3337
3338 for (i = 0; i < stream_size (o); ++i)
3339 stream_put (s, stream_data (o)[i]);
3340
3341 stream_free (o);
3342}
3343
3344// calculates a (preferably small) integer that makes it possible to find
3345// the symbol again. if pointers were offsets into a memory area... until
3346// then, we return segment number in the low bits, and offset in the high
3347// bits.
3348// also, this function must never return 0.
3349ecb_cold static uint32_t
3350symbol_id (SCHEME_P_ pointer sym)
3351{
3352 struct cell *p = CELL (sym);
3353 int i;
3354
3355 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3356 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3357 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3358
3359 abort ();
3360}
3361
3362ecb_cold static uint32_t
3363cell_id (SCHEME_P_ pointer p)
3364{
3365 return symbol_id (SCHEME_A_ p);
3366}
3367
3368enum byteop
3369{
3370 BOP_NIL,
3371 BOP_SYNTAX,
3372 BOP_INTEGER,
3373 BOP_SYMBOL,
3374 BOP_LIST_BEG,
3375 BOP_LIST_END,
3376 BOP_BIFT, // branch if true
3377 BOP_BIFF, // branch if false
3378 BOP_BIFNE, // branch if not eqv?
3379 BOP_BRA, // "short" branch
3380 BOP_JMP, // "long" jump
3381 BOP_DATUM,
3382 BOP_LET,
3383 BOP_LETAST,
3384 BOP_LETREC,
3385 BOP_DEFINE,
3386 BOP_MACRO,
3387 BOP_SET,
3388 BOP_BEGIN,
3389 BOP_LAMBDA,
3390};
3391
3392ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3393
3394ecb_cold static void
3395compile_list (SCHEME_P_ stream s, pointer x)
3396{
3397 for (; x != NIL; x = cdr (x))
3398 compile_expr (SCHEME_A_ s, car (x));
3399}
3400
3401static void
3402compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3403{
3404 //TODO: borked
3405 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3406
3407 stream_put (s, BOP_BIFF);
3408 compile_expr (SCHEME_A_ s, cond);
3409 stream_put_v (s, stream_size (sift));
3410 stream_put_stream (s, sift);
3411
3412 if (iff != NIL)
3413 {
3414 stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff);
3415 stream_put_tv (s, BOP_BRA, stream_size (siff));
3416 stream_put_stream (s, siff);
3417 }
3418}
3419
3420typedef uint32_t stream_fixup;
3421
3422static stream_fixup
3423stream_put_fixup (stream s)
3424{
3425 stream_put (s, 0);
3426 stream_put (s, 0);
3427
3428 return stream_size (s);
3429}
3430
3431static void
3432stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3433{
3434 target -= fixup;
3435 assert (target < (1 << 14));
3436 stream_data (s)[fixup - 2] = target | 0x80;
3437 stream_data (s)[fixup - 1] = target >> 7;
3438}
3439
3440static void
3441compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3442{
3443 if (cdr (x) == NIL)
3444 compile_expr (SCHEME_A_ s, car (x));
3445 else
3446 {
3447 stream_put (s, and ? BOP_BIFF : BOP_BIFT);
3448 compile_expr (SCHEME_A_ s, car (x));
3449 stream_fixup end = stream_put_fixup (s);
3450
3451 compile_and_or (SCHEME_A_ s, and, cdr (x));
3452 stream_fix_fixup (s, end, stream_size (s));
3453 }
3454}
3455
3456ecb_cold static void
3457compile_expr (SCHEME_P_ stream s, pointer x)
3458{
3459 if (x == NIL)
3460 {
3461 stream_put (s, BOP_NIL);
3462 return;
3463 }
3464
3465 if (is_pair (x))
3466 {
3467 pointer head = car (x);
3468
3469 if (is_syntax (head))
3470 {
3471 x = cdr (x);
3472
3473 switch (syntaxnum (head))
3474 {
3475 case OP_IF0: /* if */
3476 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3477 break;
3478
3479 case OP_OR0: /* or */
3480 compile_and_or (SCHEME_A_ s, 0, x);
3481 break;
3482
3483 case OP_AND0: /* and */
3484 compile_and_or (SCHEME_A_ s, 1, x);
3485 break;
3486
3487 case OP_CASE0: /* case */
3488 abort ();
3489 break;
3490
3491 case OP_COND0: /* cond */
3492 abort ();
3493 break;
3494
3495 case OP_LET0: /* let */
3496 case OP_LET0AST: /* let* */
3497 case OP_LET0REC: /* letrec */
3498 switch (syntaxnum (head))
3499 {
3500 case OP_LET0: stream_put (s, BOP_LET ); break;
3501 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3502 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3503 }
3504
3505 {
3506 pointer bindings = car (x);
3507 pointer body = cadr (x);
3508
3509 for (x = bindings; x != NIL; x = cdr (x))
3510 {
3511 pointer init = NIL;
3512 pointer var = car (x);
3513
3514 if (is_pair (var))
3515 {
3516 init = cdr (var);
3517 var = car (var);
3518 }
3519
3520 stream_put_v (s, symbol_id (SCHEME_A_ var));
3521 compile_expr (SCHEME_A_ s, init);
3522 }
3523
3524 stream_put_v (s, 0);
3525 compile_expr (SCHEME_A_ s, body);
3526 }
3527 break;
3528
3529 case OP_DEF0: /* define */
3530 case OP_MACRO0: /* macro */
3531 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3532 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3533 compile_expr (SCHEME_A_ s, cadr (x));
3534 break;
3535
3536 case OP_SET0: /* set! */
3537 stream_put (s, BOP_SET);
3538 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3539 compile_expr (SCHEME_A_ s, cadr (x));
3540 break;
3541
3542 case OP_BEGIN: /* begin */
3543 stream_put (s, BOP_BEGIN);
3544 compile_list (SCHEME_A_ s, x);
3545 return;
3546
3547 case OP_DELAY: /* delay */
3548 abort ();
3549 break;
3550
3551 case OP_QUOTE: /* quote */
3552 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3553 break;
3554
3555 case OP_LAMBDA: /* lambda */
3556 {
3557 pointer formals = car (x);
3558 pointer body = cadr (x);
3559
3560 stream_put (s, BOP_LAMBDA);
3561
3562 for (; is_pair (formals); formals = cdr (formals))
3563 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3564
3565 stream_put_v (s, 0);
3566 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3567
3568 compile_expr (SCHEME_A_ s, body);
3569 }
3570 break;
3571
3572 case OP_C0STREAM:/* cons-stream */
3573 abort ();
3574 break;
3575 }
3576
3577 return;
3578 }
3579
3580 pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);
3581
3582 if (m != NIL)
3583 {
3584 m = slot_value_in_env (m);
3585
3586 if (is_macro (m))
3587 {
3588 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3589 SCHEME_V->code = m;
3590 SCHEME_V->args = cons (x, NIL);
3591 Eval_Cycle (SCHEME_A_ OP_APPLY);
3592 x = SCHEME_V->value;
3593 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3594 return;
3595 }
3596 }
3597 }
3598
3599 switch (type (x))
3600 {
3601 case T_INTEGER:
3602 {
3603 IVALUE iv = ivalue_unchecked (x);
3604 iv = iv < 0 ? ((uint32_t)-iv << 1) | 1 : (uint32_t)iv << 1;
3605 stream_put_tv (s, BOP_INTEGER, iv);
3606 }
3607 return;
3608
3609 case T_SYMBOL:
3610 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3611 return;
3612
3613 case T_PAIR:
3614 stream_put (s, BOP_LIST_BEG);
3615
3616 for (; x != NIL; x = cdr (x))
3617 compile_expr (SCHEME_A_ s, car (x));
3618
3619 stream_put (s, BOP_LIST_END);
3620 return;
3621
3622 default:
3623 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3624 break;
3625 }
3626}
3627
3628ecb_cold static int
3629compile_closure (SCHEME_P_ pointer p)
3630{
3631 stream s = stream_init ();
3632
3633 compile_list (SCHEME_A_ s, cdar (p));
3634
3635 FILE *xxd = popen ("xxd", "we");
3636 fwrite (stream_data (s), 1, stream_size (s), xxd);
3637 fclose (xxd);
3638
3639 return stream_size (s);
3640}
3641
3413#endif 3642#endif
3414 3643
3415/* syntax, eval, core, ... */ 3644/* syntax, eval, core, ... */
3416ecb_hot static int 3645ecb_hot static int
3417opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3646opexe_0 (SCHEME_P_ enum scheme_opcodes op)
… …
3427 uint32_t len = compile_closure (SCHEME_A_ car (args)); 3656 uint32_t len = compile_closure (SCHEME_A_ car (args));
3428 printf ("len = %d\n", len); 3657 printf ("len = %d\n", len);
3429 printf ("\n"); 3658 printf ("\n");
3430 s_return (S_T); 3659 s_return (S_T);
3431 } 3660 }
3661
3662 case OP_DEBUG2:
3663 return -1;
3432#endif 3664#endif
3665
3433 case OP_LOAD: /* load */ 3666 case OP_LOAD: /* load */
3434 if (file_interactive (SCHEME_A)) 3667 if (file_interactive (SCHEME_A))
3435 { 3668 {
3436 putstr (SCHEME_A_ "Loading "); 3669 putstr (SCHEME_A_ "Loading ");
3437 putstr (SCHEME_A_ strvalue (car (args))); 3670 putstr (SCHEME_A_ strvalue (car (args)));
… …
3569 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3802 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3570 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3803 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3571 SCHEME_V->code = SCHEME_V->value; 3804 SCHEME_V->code = SCHEME_V->value;
3572 s_goto (OP_APPLY); 3805 s_goto (OP_APPLY);
3573 } 3806 }
3574 else 3807
3575 {
3576 SCHEME_V->code = cdr (SCHEME_V->code); 3808 SCHEME_V->code = cdr (SCHEME_V->code);
3577 s_goto (OP_E1ARGS); 3809 s_goto (OP_E1ARGS);
3578 }
3579 3810
3580 case OP_E1ARGS: /* eval arguments */ 3811 case OP_E1ARGS: /* eval arguments */
3581 args = cons (SCHEME_V->value, args); 3812 args = cons (SCHEME_V->value, args);
3582 3813
3583 if (is_pair (SCHEME_V->code)) /* continue */ 3814 if (is_pair (SCHEME_V->code)) /* continue */
… …
3594 SCHEME_V->args = cdr (args); 3825 SCHEME_V->args = cdr (args);
3595 s_goto (OP_APPLY); 3826 s_goto (OP_APPLY);
3596 } 3827 }
3597 3828
3598#if USE_TRACING 3829#if USE_TRACING
3599
3600 case OP_TRACING: 3830 case OP_TRACING:
3601 { 3831 {
3602 int tr = SCHEME_V->tracing; 3832 int tr = SCHEME_V->tracing;
3603 3833
3604 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3834 SCHEME_V->tracing = ivalue_unchecked (car (args));
3605 s_return (mk_integer (SCHEME_A_ tr)); 3835 s_return (mk_integer (SCHEME_A_ tr));
3606 } 3836 }
3607
3608#endif 3837#endif
3609 3838
3610 case OP_APPLY: /* apply 'code' to 'args' */ 3839 case OP_APPLY: /* apply 'code' to 'args' */
3611#if USE_TRACING 3840#if USE_TRACING
3612 if (SCHEME_V->tracing) 3841 if (SCHEME_V->tracing)
… …
3666 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3895 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3667 { 3896 {
3668 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3897 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3669 s_return (args != NIL ? car (args) : NIL); 3898 s_return (args != NIL ? car (args) : NIL);
3670 } 3899 }
3671 else 3900
3672 Error_0 ("illegal function"); 3901 Error_0 ("illegal function");
3673 3902
3674 case OP_DOMACRO: /* do macro */ 3903 case OP_DOMACRO: /* do macro */
3675 SCHEME_V->code = SCHEME_V->value; 3904 SCHEME_V->code = SCHEME_V->value;
3676 s_goto (OP_EVAL); 3905 s_goto (OP_EVAL);
3677 3906
… …
3798 SCHEME_V->value = SCHEME_V->code; 4027 SCHEME_V->value = SCHEME_V->code;
3799 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4028 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3800 s_goto (OP_LET1); 4029 s_goto (OP_LET1);
3801 4030
3802 case OP_LET1: /* let (calculate parameters) */ 4031 case OP_LET1: /* let (calculate parameters) */
4032 case OP_LET1REC: /* letrec (calculate parameters) */
3803 args = cons (SCHEME_V->value, args); 4033 args = cons (SCHEME_V->value, args);
3804 4034
3805 if (is_pair (SCHEME_V->code)) /* continue */ 4035 if (is_pair (SCHEME_V->code)) /* continue */
3806 { 4036 {
3807 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4037 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3808 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4038 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3809 4039
3810 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4040 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3811 SCHEME_V->code = cadar (SCHEME_V->code); 4041 SCHEME_V->code = cadar (SCHEME_V->code);
3812 SCHEME_V->args = NIL; 4042 SCHEME_V->args = NIL;
3813 s_goto (OP_EVAL); 4043 s_goto (OP_EVAL);
3814 } 4044 }
3815 else /* end */ 4045
3816 { 4046 /* end */
3817 args = reverse_in_place (SCHEME_A_ NIL, args); 4047 args = reverse_in_place (SCHEME_A_ NIL, args);
3818 SCHEME_V->code = car (args); 4048 SCHEME_V->code = car (args);
3819 SCHEME_V->args = cdr (args); 4049 SCHEME_V->args = cdr (args);
3820 s_goto (OP_LET2); 4050 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3821 }
3822 4051
3823 case OP_LET2: /* let */ 4052 case OP_LET2: /* let */
3824 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4053 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3825 4054
3826 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4055 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3830 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4059 if (is_symbol (car (SCHEME_V->code))) /* named let */
3831 { 4060 {
3832 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4061 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3833 { 4062 {
3834 if (!is_pair (x)) 4063 if (!is_pair (x))
3835 Error_1 ("Bad syntax of binding in let :", x); 4064 Error_1 ("Bad syntax of binding in let:", x);
3836 4065
3837 if (!is_list (SCHEME_A_ car (x))) 4066 if (!is_list (SCHEME_A_ car (x)))
3838 Error_1 ("Bad syntax of binding in let :", car (x)); 4067 Error_1 ("Bad syntax of binding in let:", car (x));
3839 4068
3840 args = cons (caar (x), args); 4069 args = cons (caar (x), args);
3841 } 4070 }
3842 4071
3843 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4072 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3860 SCHEME_V->code = cdr (SCHEME_V->code); 4089 SCHEME_V->code = cdr (SCHEME_V->code);
3861 s_goto (OP_BEGIN); 4090 s_goto (OP_BEGIN);
3862 } 4091 }
3863 4092
3864 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4093 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3865 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4094 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3866 4095
3867 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4096 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3868 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4097 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3869 s_goto (OP_EVAL); 4098 s_goto (OP_EVAL);
3870 4099
… …
3881 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4110 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3882 SCHEME_V->code = cadar (SCHEME_V->code); 4111 SCHEME_V->code = cadar (SCHEME_V->code);
3883 SCHEME_V->args = NIL; 4112 SCHEME_V->args = NIL;
3884 s_goto (OP_EVAL); 4113 s_goto (OP_EVAL);
3885 } 4114 }
3886 else /* end */ 4115
4116 /* end */
3887 { 4117
3888 SCHEME_V->code = args; 4118 SCHEME_V->code = args;
3889 SCHEME_V->args = NIL; 4119 SCHEME_V->args = NIL;
3890 s_goto (OP_BEGIN); 4120 s_goto (OP_BEGIN);
3891 }
3892 4121
3893 case OP_LET0REC: /* letrec */ 4122 case OP_LET0REC: /* letrec */
3894 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4123 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3895 SCHEME_V->args = NIL; 4124 SCHEME_V->args = NIL;
3896 SCHEME_V->value = SCHEME_V->code; 4125 SCHEME_V->value = SCHEME_V->code;
3897 SCHEME_V->code = car (SCHEME_V->code); 4126 SCHEME_V->code = car (SCHEME_V->code);
3898 s_goto (OP_LET1REC); 4127 s_goto (OP_LET1REC);
3899 4128
3900 case OP_LET1REC: /* letrec (calculate parameters) */ 4129 /* OP_LET1REC handled by OP_LET1 */
3901 args = cons (SCHEME_V->value, args);
3902
3903 if (is_pair (SCHEME_V->code)) /* continue */
3904 {
3905 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3906 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3907
3908 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3909 SCHEME_V->code = cadar (SCHEME_V->code);
3910 SCHEME_V->args = NIL;
3911 s_goto (OP_EVAL);
3912 }
3913 else /* end */
3914 {
3915 args = reverse_in_place (SCHEME_A_ NIL, args);
3916 SCHEME_V->code = car (args);
3917 SCHEME_V->args = cdr (args);
3918 s_goto (OP_LET2REC);
3919 }
3920 4130
3921 case OP_LET2REC: /* letrec */ 4131 case OP_LET2REC: /* letrec */
3922 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4132 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3923 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4133 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3924 4134
… …
5091 case OP_RDSEXPR: 5301 case OP_RDSEXPR:
5092 switch (SCHEME_V->tok) 5302 switch (SCHEME_V->tok)
5093 { 5303 {
5094 case TOK_EOF: 5304 case TOK_EOF:
5095 s_return (S_EOF); 5305 s_return (S_EOF);
5096 /* NOTREACHED */
5097 5306
5098 case TOK_VEC: 5307 case TOK_VEC:
5099 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5308 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5100 /* fall through */ 5309 /* fall through */
5101 5310
… …
5104 5313
5105 if (SCHEME_V->tok == TOK_RPAREN) 5314 if (SCHEME_V->tok == TOK_RPAREN)
5106 s_return (NIL); 5315 s_return (NIL);
5107 else if (SCHEME_V->tok == TOK_DOT) 5316 else if (SCHEME_V->tok == TOK_DOT)
5108 Error_0 ("syntax error: illegal dot expression"); 5317 Error_0 ("syntax error: illegal dot expression");
5109 else 5318
5110 {
5111 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5319 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5112 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5320 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5113 s_goto (OP_RDSEXPR); 5321 s_goto (OP_RDSEXPR);
5114 }
5115 5322
5116 case TOK_QUOTE: 5323 case TOK_QUOTE:
5117 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5324 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5118 SCHEME_V->tok = token (SCHEME_A); 5325 SCHEME_V->tok = token (SCHEME_A);
5119 s_goto (OP_RDSEXPR); 5326 s_goto (OP_RDSEXPR);
… …
5125 { 5332 {
5126 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5333 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5127 SCHEME_V->tok = TOK_LPAREN; 5334 SCHEME_V->tok = TOK_LPAREN;
5128 s_goto (OP_RDSEXPR); 5335 s_goto (OP_RDSEXPR);
5129 } 5336 }
5130 else 5337
5131 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5338 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5132
5133 s_goto (OP_RDSEXPR); 5339 s_goto (OP_RDSEXPR);
5134 5340
5135 case TOK_COMMA: 5341 case TOK_COMMA:
5136 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5342 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5137 SCHEME_V->tok = token (SCHEME_A); 5343 SCHEME_V->tok = token (SCHEME_A);
… …
5148 case TOK_DOTATOM: 5354 case TOK_DOTATOM:
5149 SCHEME_V->strbuff[0] = '.'; 5355 SCHEME_V->strbuff[0] = '.';
5150 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5356 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5151 5357
5152 case TOK_STRATOM: 5358 case TOK_STRATOM:
5359 //TODO: haven't checked whether the garbage collector could interfere and free x
5360 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5153 x = readstrexp (SCHEME_A_ '|'); 5361 x = readstrexp (SCHEME_A_ '|');
5154 //TODO: haven't checked whether the garbage collector could interfere
5155 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5362 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5156 5363
5157 case TOK_DQUOTE: 5364 case TOK_DQUOTE:
5158 x = readstrexp (SCHEME_A_ '"'); 5365 x = readstrexp (SCHEME_A_ '"');
5159 5366
… …
5167 { 5374 {
5168 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5375 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5169 5376
5170 if (f == NIL) 5377 if (f == NIL)
5171 Error_0 ("undefined sharp expression"); 5378 Error_0 ("undefined sharp expression");
5172 else 5379
5173 {
5174 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5380 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5175 s_goto (OP_EVAL); 5381 s_goto (OP_EVAL);
5176 }
5177 } 5382 }
5178 5383
5179 case TOK_SHARP_CONST: 5384 case TOK_SHARP_CONST:
5180 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5385 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5181 Error_0 ("undefined sharp expression"); 5386 Error_0 ("undefined sharp expression");
5182 else 5387
5183 s_return (x); 5388 s_return (x);
5184 5389
5185 default: 5390 default:
5186 Error_0 ("syntax error: illegal token"); 5391 Error_0 ("syntax error: illegal token");
5187 } 5392 }
5188 5393

Diff Legend

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