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

Comparing microscheme/scheme.c (file contents):
Revision 1.15 by root, Thu Nov 26 09:05:20 2015 UTC vs.
Revision 1.16 by root, Thu Nov 26 10:02:58 2015 UTC

… …
70/* should use libecb */ 70/* should use libecb */
71#if __GNUC__ >= 4 71#if __GNUC__ >= 4
72# define ecb_expect(expr,value) __builtin_expect ((expr),(value)) 72# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73# define ecb_expect_false(expr) ecb_expect (!!(expr), 0) 73# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74# define ecb_expect_true(expr) ecb_expect (!!(expr), 1) 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)
75#endif 78#endif
76 79
77#if !USE_MULTIPLICITY 80#if !USE_MULTIPLICITY
78static scheme sc; 81static scheme sc;
79#endif 82#endif
… …
819 return ce; 822 return ce;
820 else if (dfl < dce) 823 else if (dfl < dce)
821 return fl; 824 return fl;
822 else 825 else
823 { 826 {
824 if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */ 827 if (fmod (fl, 2) == 0) /* I imagine this holds */
825 return fl; 828 return fl;
826 else 829 else
827 return ce; 830 return ce;
828 } 831 }
829} 832}
… …
3031 next_frame = SCHEME_V->dump_base + nframes; 3034 next_frame = SCHEME_V->dump_base + nframes;
3032 3035
3033 next_frame->op = op; 3036 next_frame->op = op;
3034 next_frame->args = args; 3037 next_frame->args = args;
3035 next_frame->envir = SCHEME_V->envir; 3038 next_frame->envir = SCHEME_V->envir;
3036 next_frame->code = code; 3039 next_frame->code = code;
3037 3040
3038 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3041 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3039} 3042}
3040 3043
3041static pointer 3044static pointer
… …
3214#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3217#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3215 3218
3216static pointer 3219static pointer
3217opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3220opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3218{ 3221{
3222 pointer args = SCHEME_V->args;
3219 pointer x, y; 3223 pointer x, y;
3220 3224
3221 switch (op) 3225 switch (op)
3222 { 3226 {
3223 case OP_LOAD: /* load */ 3227 case OP_LOAD: /* load */
3224 if (file_interactive (SCHEME_A)) 3228 if (file_interactive (SCHEME_A))
3225 { 3229 {
3226 xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n"); 3230 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3227 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args))); 3231 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3228 } 3232 }
3229 3233
3230 if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args)))) 3234 if (!file_push (SCHEME_A_ strvalue (car (args))))
3231 Error_1 ("unable to open", car (SCHEME_V->args)); 3235 Error_1 ("unable to open", car (args));
3232 else 3236 else
3233 { 3237 {
3234 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3238 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3235 s_goto (OP_T0LVL); 3239 s_goto (OP_T0LVL);
3236 } 3240 }
… …
3310 case OP_EVAL: /* main part of evaluation */ 3314 case OP_EVAL: /* main part of evaluation */
3311#if USE_TRACING 3315#if USE_TRACING
3312 if (SCHEME_V->tracing) 3316 if (SCHEME_V->tracing)
3313 { 3317 {
3314 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ 3318 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
3315 s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code); 3319 s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
3316 SCHEME_V->args = SCHEME_V->code; 3320 SCHEME_V->args = SCHEME_V->code;
3317 putstr (SCHEME_A_ "\nEval: "); 3321 putstr (SCHEME_A_ "\nEval: ");
3318 s_goto (OP_P0LIST); 3322 s_goto (OP_P0LIST);
3319 } 3323 }
3320 3324
… …
3364 SCHEME_V->code = cdr (SCHEME_V->code); 3368 SCHEME_V->code = cdr (SCHEME_V->code);
3365 s_goto (OP_E1ARGS); 3369 s_goto (OP_E1ARGS);
3366 } 3370 }
3367 3371
3368 case OP_E1ARGS: /* eval arguments */ 3372 case OP_E1ARGS: /* eval arguments */
3369 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3373 args = cons (SCHEME_V->value, args);
3370 3374
3371 if (is_pair (SCHEME_V->code)) /* continue */ 3375 if (is_pair (SCHEME_V->code)) /* continue */
3372 { 3376 {
3373 s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code)); 3377 s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
3374 SCHEME_V->code = car (SCHEME_V->code); 3378 SCHEME_V->code = car (SCHEME_V->code);
3375 SCHEME_V->args = NIL; 3379 SCHEME_V->args = NIL;
3376 s_goto (OP_EVAL); 3380 s_goto (OP_EVAL);
3377 } 3381 }
3378 else /* end */ 3382 else /* end */
3379 { 3383 {
3380 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3384 args = reverse_in_place (SCHEME_A_ NIL, args);
3381 SCHEME_V->code = car (SCHEME_V->args); 3385 SCHEME_V->code = car (args);
3382 SCHEME_V->args = cdr (SCHEME_V->args); 3386 SCHEME_V->args = cdr (args);
3383 s_goto (OP_APPLY); 3387 s_goto (OP_APPLY);
3384 } 3388 }
3385 3389
3386#if USE_TRACING 3390#if USE_TRACING
3387 3391
3388 case OP_TRACING: 3392 case OP_TRACING:
3389 { 3393 {
3390 int tr = SCHEME_V->tracing; 3394 int tr = SCHEME_V->tracing;
3391 3395
3392 SCHEME_V->tracing = ivalue (car (SCHEME_V->args)); 3396 SCHEME_V->tracing = ivalue (car (args));
3393 s_return (mk_integer (SCHEME_A_ tr)); 3397 s_return (mk_integer (SCHEME_A_ tr));
3394 } 3398 }
3395 3399
3396#endif 3400#endif
3397 3401
3398 case OP_APPLY: /* apply 'code' to 'args' */ 3402 case OP_APPLY: /* apply 'code' to 'args' */
3399#if USE_TRACING 3403#if USE_TRACING
3400 if (SCHEME_V->tracing) 3404 if (SCHEME_V->tracing)
3401 { 3405 {
3402 s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code); 3406 s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
3403 SCHEME_V->print_flag = 1; 3407 SCHEME_V->print_flag = 1;
3404 /* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */ 3408 /* args=cons(SCHEME_V->code,args); */
3405 putstr (SCHEME_A_ "\nApply to: "); 3409 putstr (SCHEME_A_ "\nApply to: ");
3406 s_goto (OP_P0LIST); 3410 s_goto (OP_P0LIST);
3407 } 3411 }
3408 3412
3409 /* fall through */ 3413 /* fall through */
… …
3415 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3419 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3416 } 3420 }
3417 else if (is_foreign (SCHEME_V->code)) 3421 else if (is_foreign (SCHEME_V->code))
3418 { 3422 {
3419 /* Keep nested calls from GC'ing the arglist */ 3423 /* Keep nested calls from GC'ing the arglist */
3420 push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL); 3424 push_recent_alloc (SCHEME_A_ args, NIL);
3421 x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args); 3425 x = SCHEME_V->code->object.ff (SCHEME_A_ args);
3422 3426
3423 s_return (x); 3427 s_return (x);
3424 } 3428 }
3425 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3429 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3426 { 3430 {
3427 /* Should not accept promise */ 3431 /* Should not accept promise */
3428 /* make environment */ 3432 /* make environment */
3429 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); 3433 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3430 3434
3431 for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) 3435 for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
3432 { 3436 {
3433 if (y == NIL) 3437 if (y == NIL)
3434 Error_0 ("not enough arguments"); 3438 Error_0 ("not enough arguments");
3435 else 3439 else
3436 new_slot_in_env (SCHEME_A_ car (x), car (y)); 3440 new_slot_in_env (SCHEME_A_ car (x), car (y));
… …
3454 s_goto (OP_BEGIN); 3458 s_goto (OP_BEGIN);
3455 } 3459 }
3456 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3460 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3457 { 3461 {
3458 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3462 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3459 s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL); 3463 s_return (args != NIL ? car (args) : NIL);
3460 } 3464 }
3461 else 3465 else
3462 Error_0 ("illegal function"); 3466 Error_0 ("illegal function");
3463 3467
3464 case OP_DOMACRO: /* do macro */ 3468 case OP_DOMACRO: /* do macro */
… …
3473 { 3477 {
3474 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3478 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
3475 3479
3476 if (f != NIL) 3480 if (f != NIL)
3477 { 3481 {
3478 s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code); 3482 s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
3479 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3483 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3480 SCHEME_V->code = slot_value_in_env (f); 3484 SCHEME_V->code = slot_value_in_env (f);
3481 s_goto (OP_APPLY); 3485 s_goto (OP_APPLY);
3482 } 3486 }
3483 3487
… …
3494 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir)); 3498 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3495 3499
3496#endif 3500#endif
3497 3501
3498 case OP_MKCLOSURE: /* make-closure */ 3502 case OP_MKCLOSURE: /* make-closure */
3499 x = car (SCHEME_V->args); 3503 x = car (args);
3500 3504
3501 if (car (x) == SCHEME_V->LAMBDA) 3505 if (car (x) == SCHEME_V->LAMBDA)
3502 x = cdr (x); 3506 x = cdr (x);
3503 3507
3504 if (cdr (SCHEME_V->args) == NIL) 3508 if (cdr (args) == NIL)
3505 y = SCHEME_V->envir; 3509 y = SCHEME_V->envir;
3506 else 3510 else
3507 y = cadr (SCHEME_V->args); 3511 y = cadr (args);
3508 3512
3509 s_return (mk_closure (SCHEME_A_ x, y)); 3513 s_return (mk_closure (SCHEME_A_ x, y));
3510 3514
3511 case OP_QUOTE: /* quote */ 3515 case OP_QUOTE: /* quote */
3512 s_return (car (SCHEME_V->code)); 3516 s_return (car (SCHEME_V->code));
… …
3544 3548
3545 3549
3546 case OP_DEFP: /* defined? */ 3550 case OP_DEFP: /* defined? */
3547 x = SCHEME_V->envir; 3551 x = SCHEME_V->envir;
3548 3552
3549 if (cdr (SCHEME_V->args) != NIL) 3553 if (cdr (args) != NIL)
3550 x = cadr (SCHEME_V->args); 3554 x = cadr (args);
3551 3555
3552 s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); 3556 s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);
3553 3557
3554 case OP_SET0: /* set! */ 3558 case OP_SET0: /* set! */
3555 if (is_immutable (car (SCHEME_V->code))) 3559 if (is_immutable (car (SCHEME_V->code)))
3556 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code)); 3560 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));
3557 3561
… …
3600 SCHEME_V->value = SCHEME_V->code; 3604 SCHEME_V->value = SCHEME_V->code;
3601 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 3605 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3602 s_goto (OP_LET1); 3606 s_goto (OP_LET1);
3603 3607
3604 case OP_LET1: /* let (calculate parameters) */ 3608 case OP_LET1: /* let (calculate parameters) */
3605 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3609 args = cons (SCHEME_V->value, args);
3606 3610
3607 if (is_pair (SCHEME_V->code)) /* continue */ 3611 if (is_pair (SCHEME_V->code)) /* continue */
3608 { 3612 {
3609 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3613 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3610 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 3614 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3611 3615
3612 s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); 3616 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
3613 SCHEME_V->code = cadar (SCHEME_V->code); 3617 SCHEME_V->code = cadar (SCHEME_V->code);
3614 SCHEME_V->args = NIL; 3618 SCHEME_V->args = NIL;
3615 s_goto (OP_EVAL); 3619 s_goto (OP_EVAL);
3616 } 3620 }
3617 else /* end */ 3621 else /* end */
3618 { 3622 {
3619 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3623 args = reverse_in_place (SCHEME_A_ NIL, args);
3620 SCHEME_V->code = car (SCHEME_V->args); 3624 SCHEME_V->code = car (args);
3621 SCHEME_V->args = cdr (SCHEME_V->args); 3625 SCHEME_V->args = cdr (args);
3622 s_goto (OP_LET2); 3626 s_goto (OP_LET2);
3623 } 3627 }
3624 3628
3625 case OP_LET2: /* let */ 3629 case OP_LET2: /* let */
3626 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3630 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3627 3631
3628 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; 3632 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3629 y != NIL; x = cdr (x), y = cdr (y)) 3633 y != NIL; x = cdr (x), y = cdr (y))
3630 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3634 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3631 3635
3632 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3636 if (is_symbol (car (SCHEME_V->code))) /* named let */
3633 { 3637 {
3634 for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) 3638 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3635 { 3639 {
3636 if (!is_pair (x)) 3640 if (!is_pair (x))
3637 Error_1 ("Bad syntax of binding in let :", x); 3641 Error_1 ("Bad syntax of binding in let :", x);
3638 3642
3639 if (!is_list (SCHEME_A_ car (x))) 3643 if (!is_list (SCHEME_A_ car (x)))
3640 Error_1 ("Bad syntax of binding in let :", car (x)); 3644 Error_1 ("Bad syntax of binding in let :", car (x));
3641 3645
3642 SCHEME_V->args = cons (caar (x), SCHEME_V->args); 3646 args = cons (caar (x), args);
3643 } 3647 }
3644 3648
3645 x =
3646 mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)), 3649 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
3647 SCHEME_V->envir); 3650 SCHEME_V->envir);
3648 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); 3651 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
3649 SCHEME_V->code = cddr (SCHEME_V->code); 3652 SCHEME_V->code = cddr (SCHEME_V->code);
3650 SCHEME_V->args = NIL;
3651 } 3653 }
3652 else 3654 else
3653 { 3655 {
3654 SCHEME_V->code = cdr (SCHEME_V->code); 3656 SCHEME_V->code = cdr (SCHEME_V->code);
3657 }
3658
3655 SCHEME_V->args = NIL; 3659 SCHEME_V->args = NIL;
3656 }
3657
3658 s_goto (OP_BEGIN); 3660 s_goto (OP_BEGIN);
3659 3661
3660 case OP_LET0AST: /* let* */ 3662 case OP_LET0AST: /* let* */
3661 if (car (SCHEME_V->code) == NIL) 3663 if (car (SCHEME_V->code) == NIL)
3662 { 3664 {
… …
3680 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value); 3682 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
3681 SCHEME_V->code = cdr (SCHEME_V->code); 3683 SCHEME_V->code = cdr (SCHEME_V->code);
3682 3684
3683 if (is_pair (SCHEME_V->code)) /* continue */ 3685 if (is_pair (SCHEME_V->code)) /* continue */
3684 { 3686 {
3685 s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code); 3687 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3686 SCHEME_V->code = cadar (SCHEME_V->code); 3688 SCHEME_V->code = cadar (SCHEME_V->code);
3687 SCHEME_V->args = NIL; 3689 SCHEME_V->args = NIL;
3688 s_goto (OP_EVAL); 3690 s_goto (OP_EVAL);
3689 } 3691 }
3690 else /* end */ 3692 else /* end */
3691 { 3693 {
3692 SCHEME_V->code = SCHEME_V->args; 3694 SCHEME_V->code = args;
3693 SCHEME_V->args = NIL; 3695 SCHEME_V->args = NIL;
3694 s_goto (OP_BEGIN); 3696 s_goto (OP_BEGIN);
3695 } 3697 }
3696 3698
3697 case OP_LET0REC: /* letrec */ 3699 case OP_LET0REC: /* letrec */
… …
3700 SCHEME_V->value = SCHEME_V->code; 3702 SCHEME_V->value = SCHEME_V->code;
3701 SCHEME_V->code = car (SCHEME_V->code); 3703 SCHEME_V->code = car (SCHEME_V->code);
3702 s_goto (OP_LET1REC); 3704 s_goto (OP_LET1REC);
3703 3705
3704 case OP_LET1REC: /* letrec (calculate parameters) */ 3706 case OP_LET1REC: /* letrec (calculate parameters) */
3705 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3707 args = cons (SCHEME_V->value, args);
3706 3708
3707 if (is_pair (SCHEME_V->code)) /* continue */ 3709 if (is_pair (SCHEME_V->code)) /* continue */
3708 { 3710 {
3709 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3711 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3710 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); 3712 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3711 3713
3712 s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); 3714 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3713 SCHEME_V->code = cadar (SCHEME_V->code); 3715 SCHEME_V->code = cadar (SCHEME_V->code);
3714 SCHEME_V->args = NIL; 3716 SCHEME_V->args = NIL;
3715 s_goto (OP_EVAL); 3717 s_goto (OP_EVAL);
3716 } 3718 }
3717 else /* end */ 3719 else /* end */
3718 { 3720 {
3719 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3721 args = reverse_in_place (SCHEME_A_ NIL, args);
3720 SCHEME_V->code = car (SCHEME_V->args); 3722 SCHEME_V->code = car (args);
3721 SCHEME_V->args = cdr (SCHEME_V->args); 3723 SCHEME_V->args = cdr (args);
3722 s_goto (OP_LET2REC); 3724 s_goto (OP_LET2REC);
3723 } 3725 }
3724 3726
3725 case OP_LET2REC: /* letrec */ 3727 case OP_LET2REC: /* letrec */
3726 for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) 3728 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3727 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3729 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3728 3730
3729 SCHEME_V->code = cdr (SCHEME_V->code); 3731 SCHEME_V->code = cdr (SCHEME_V->code);
3730 SCHEME_V->args = NIL; 3732 SCHEME_V->args = NIL;
3731 s_goto (OP_BEGIN); 3733 s_goto (OP_BEGIN);
… …
3817 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 3819 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3818 SCHEME_V->code = car (SCHEME_V->code); 3820 SCHEME_V->code = car (SCHEME_V->code);
3819 s_goto (OP_EVAL); 3821 s_goto (OP_EVAL);
3820 3822
3821 case OP_C1STREAM: /* cons-stream */ 3823 case OP_C1STREAM: /* cons-stream */
3822 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */ 3824 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */
3823 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3825 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3824 set_typeflag (x, T_PROMISE); 3826 set_typeflag (x, T_PROMISE);
3825 s_return (cons (SCHEME_V->args, x)); 3827 s_return (cons (args, x));
3826 3828
3827 case OP_MACRO0: /* macro */ 3829 case OP_MACRO0: /* macro */
3828 if (is_pair (car (SCHEME_V->code))) 3830 if (is_pair (car (SCHEME_V->code)))
3829 { 3831 {
3830 x = caar (SCHEME_V->code); 3832 x = caar (SCHEME_V->code);
… …
3863 { 3865 {
3864 if (!is_pair (y = caar (x))) 3866 if (!is_pair (y = caar (x)))
3865 break; 3867 break;
3866 3868
3867 for (; y != NIL; y = cdr (y)) 3869 for (; y != NIL; y = cdr (y))
3868 {
3869 if (eqv (car (y), SCHEME_V->value)) 3870 if (eqv (car (y), SCHEME_V->value))
3870 break; 3871 break;
3871 }
3872 3872
3873 if (y != NIL) 3873 if (y != NIL)
3874 break; 3874 break;
3875 } 3875 }
3876 3876
… …
3896 s_goto (OP_BEGIN); 3896 s_goto (OP_BEGIN);
3897 else 3897 else
3898 s_return (NIL); 3898 s_return (NIL);
3899 3899
3900 case OP_PAPPLY: /* apply */ 3900 case OP_PAPPLY: /* apply */
3901 SCHEME_V->code = car (SCHEME_V->args); 3901 SCHEME_V->code = car (args);
3902 SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); 3902 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3903 /*SCHEME_V->args = cadr(SCHEME_V->args); */ 3903 /*SCHEME_V->args = cadr(args); */
3904 s_goto (OP_APPLY); 3904 s_goto (OP_APPLY);
3905 3905
3906 case OP_PEVAL: /* eval */ 3906 case OP_PEVAL: /* eval */
3907 if (cdr (SCHEME_V->args) != NIL) 3907 if (cdr (args) != NIL)
3908 SCHEME_V->envir = cadr (SCHEME_V->args); 3908 SCHEME_V->envir = cadr (args);
3909 3909
3910 SCHEME_V->code = car (SCHEME_V->args); 3910 SCHEME_V->code = car (args);
3911 s_goto (OP_EVAL); 3911 s_goto (OP_EVAL);
3912 3912
3913 case OP_CONTINUATION: /* call-with-current-continuation */ 3913 case OP_CONTINUATION: /* call-with-current-continuation */
3914 SCHEME_V->code = car (SCHEME_V->args); 3914 SCHEME_V->code = car (args);
3915 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); 3915 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3916 s_goto (OP_APPLY); 3916 s_goto (OP_APPLY);
3917 } 3917 }
3918 3918
3919 abort (); 3919 abort ();
3920} 3920}
3921 3921
3922static pointer 3922static pointer
3923opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3923opexe_2 (SCHEME_P_ enum scheme_opcodes op)
3924{ 3924{
3925 pointer x; 3925 pointer args = SCHEME_V->args;
3926 pointer x = car (args);
3926 num v; 3927 num v;
3927 3928
3928#if USE_MATH 3929#if USE_MATH
3929 RVALUE dd; 3930 RVALUE dd;
3930#endif 3931#endif
3931 3932
3932 switch (op) 3933 switch (op)
3933 { 3934 {
3934#if USE_MATH 3935#if USE_MATH
3935
3936 case OP_INEX2EX: /* inexact->exact */ 3936 case OP_INEX2EX: /* inexact->exact */
3937 x = car (SCHEME_V->args);
3938
3939 if (num_is_integer (x)) 3937 if (num_is_integer (x))
3940 s_return (x); 3938 s_return (x);
3941 else if (modf (rvalue_unchecked (x), &dd) == 0.0) 3939 else if (modf (rvalue_unchecked (x), &dd) == 0)
3942 s_return (mk_integer (SCHEME_A_ ivalue (x))); 3940 s_return (mk_integer (SCHEME_A_ ivalue (x)));
3943 else 3941 else
3944 Error_1 ("inexact->exact: not integral:", x); 3942 Error_1 ("inexact->exact: not integral:", x);
3945 3943
3946 case OP_EXP:
3947 x = car (SCHEME_V->args);
3948 s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 3944 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3949
3950 case OP_LOG:
3951 x = car (SCHEME_V->args);
3952 s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 3945 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));
3953
3954 case OP_SIN:
3955 x = car (SCHEME_V->args);
3956 s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 3946 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3957
3958 case OP_COS:
3959 x = car (SCHEME_V->args);
3960 s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 3947 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
3961
3962 case OP_TAN:
3963 x = car (SCHEME_V->args);
3964 s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 3948 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
3965
3966 case OP_ASIN:
3967 x = car (SCHEME_V->args);
3968 s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 3949 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
3969
3970 case OP_ACOS:
3971 x = car (SCHEME_V->args);
3972 s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 3950 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
3973 3951
3974 case OP_ATAN: 3952 case OP_ATAN:
3975 x = car (SCHEME_V->args);
3976
3977 if (cdr (SCHEME_V->args) == NIL) 3953 if (cdr (args) == NIL)
3978 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 3954 s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
3979 else 3955 else
3980 { 3956 {
3981 pointer y = cadr (SCHEME_V->args); 3957 pointer y = cadr (args);
3982
3983 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); 3958 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
3984 } 3959 }
3985 3960
3986 case OP_SQRT: 3961 case OP_SQRT:
3987 x = car (SCHEME_V->args);
3988 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); 3962 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3989 3963
3990 case OP_EXPT: 3964 case OP_EXPT:
3991 { 3965 {
3992 RVALUE result; 3966 RVALUE result;
3993 int real_result = 1; 3967 int real_result = 1;
3994 pointer y = cadr (SCHEME_V->args); 3968 pointer y = cadr (args);
3995
3996 x = car (SCHEME_V->args);
3997 3969
3998 if (num_is_integer (x) && num_is_integer (y)) 3970 if (num_is_integer (x) && num_is_integer (y))
3999 real_result = 0; 3971 real_result = 0;
4000 3972
4001 /* This 'if' is an R5RS compatibility fix. */ 3973 /* This 'if' is an R5RS compatibility fix. */
4002 /* NOTE: Remove this 'if' fix for R6RS. */ 3974 /* NOTE: Remove this 'if' fix for R6RS. */
4003 if (rvalue (x) == 0 && rvalue (y) < 0) 3975 if (rvalue (x) == 0 && rvalue (y) < 0)
4004 result = 0.0; 3976 result = 0;
4005 else 3977 else
4006 result = pow (rvalue (x), rvalue (y)); 3978 result = pow (rvalue (x), rvalue (y));
4007 3979
4008 /* Before returning integer result make sure we can. */ 3980 /* Before returning integer result make sure we can. */
4009 /* If the test fails, result is too big for integer. */ 3981 /* If the test fails, result is too big for integer. */
4010 if (!real_result) 3982 if (!real_result)
4011 { 3983 {
4012 long result_as_long = (long) result; 3984 long result_as_long = result;
4013 3985
4014 if (result != (RVALUE) result_as_long) 3986 if (result != (RVALUE) result_as_long)
4015 real_result = 1; 3987 real_result = 1;
4016 } 3988 }
4017 3989
… …
4019 s_return (mk_real (SCHEME_A_ result)); 3991 s_return (mk_real (SCHEME_A_ result));
4020 else 3992 else
4021 s_return (mk_integer (SCHEME_A_ result)); 3993 s_return (mk_integer (SCHEME_A_ result));
4022 } 3994 }
4023 3995
4024 case OP_FLOOR:
4025 x = car (SCHEME_V->args);
4026 s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 3996 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4027
4028 case OP_CEILING:
4029 x = car (SCHEME_V->args);
4030 s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); 3997 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4031 3998
4032 case OP_TRUNCATE: 3999 case OP_TRUNCATE:
4033 { 4000 {
4034 RVALUE rvalue_of_x; 4001 RVALUE rvalue_of_x;
4035 4002
4036 x = car (SCHEME_V->args);
4037 rvalue_of_x = rvalue (x); 4003 rvalue_of_x = rvalue (x);
4038 4004
4039 if (rvalue_of_x > 0) 4005 if (rvalue_of_x > 0)
4040 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); 4006 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4041 else 4007 else
4042 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x))); 4008 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4043 } 4009 }
4044 4010
4045 case OP_ROUND: 4011 case OP_ROUND:
4046 x = car (SCHEME_V->args);
4047
4048 if (num_is_integer (x)) 4012 if (num_is_integer (x))
4049 s_return (x); 4013 s_return (x);
4050 4014
4051 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); 4015 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4052#endif 4016#endif
4053 4017
4054 case OP_ADD: /* + */ 4018 case OP_ADD: /* + */
4055 v = num_zero; 4019 v = num_zero;
4056 4020
4057 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4021 for (x = args; x != NIL; x = cdr (x))
4058 v = num_op ('+', v, nvalue (car (x))); 4022 v = num_op ('+', v, nvalue (car (x)));
4059 4023
4060 s_return (mk_number (SCHEME_A_ v)); 4024 s_return (mk_number (SCHEME_A_ v));
4061 4025
4062 case OP_MUL: /* * */ 4026 case OP_MUL: /* * */
4063 v = num_one; 4027 v = num_one;
4064 4028
4065 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4029 for (x = args; x != NIL; x = cdr (x))
4066 v = num_op ('+', v, nvalue (car (x))); 4030 v = num_op ('+', v, nvalue (car (x)));
4067 4031
4068 s_return (mk_number (SCHEME_A_ v)); 4032 s_return (mk_number (SCHEME_A_ v));
4069 4033
4070 case OP_SUB: /* - */ 4034 case OP_SUB: /* - */
4071 if (cdr (SCHEME_V->args) == NIL) 4035 if (cdr (args) == NIL)
4072 { 4036 {
4073 x = SCHEME_V->args; 4037 x = args;
4074 v = num_zero; 4038 v = num_zero;
4075 } 4039 }
4076 else 4040 else
4077 { 4041 {
4078 x = cdr (SCHEME_V->args); 4042 x = cdr (args);
4079 v = nvalue (car (SCHEME_V->args)); 4043 v = nvalue (car (args));
4080 } 4044 }
4081 4045
4082 for (; x != NIL; x = cdr (x)) 4046 for (; x != NIL; x = cdr (x))
4083 v = num_op ('+', v, nvalue (car (x))); 4047 v = num_op ('+', v, nvalue (car (x)));
4084 4048
4085 s_return (mk_number (SCHEME_A_ v)); 4049 s_return (mk_number (SCHEME_A_ v));
4086 4050
4087 case OP_DIV: /* / */ 4051 case OP_DIV: /* / */
4088 if (cdr (SCHEME_V->args) == NIL) 4052 if (cdr (args) == NIL)
4089 { 4053 {
4090 x = SCHEME_V->args; 4054 x = args;
4091 v = num_one; 4055 v = num_one;
4092 } 4056 }
4093 else 4057 else
4094 { 4058 {
4095 x = cdr (SCHEME_V->args); 4059 x = cdr (args);
4096 v = nvalue (car (SCHEME_V->args)); 4060 v = nvalue (car (args));
4097 } 4061 }
4098 4062
4099 for (; x != NIL; x = cdr (x)) 4063 for (; x != NIL; x = cdr (x))
4100 { 4064 {
4101 if (!is_zero_rvalue (rvalue (car (x)))) 4065 if (!is_zero_rvalue (rvalue (car (x))))
… …
4105 } 4069 }
4106 4070
4107 s_return (mk_number (SCHEME_A_ v)); 4071 s_return (mk_number (SCHEME_A_ v));
4108 4072
4109 case OP_INTDIV: /* quotient */ 4073 case OP_INTDIV: /* quotient */
4110 if (cdr (SCHEME_V->args) == NIL) 4074 if (cdr (args) == NIL)
4111 { 4075 {
4112 x = SCHEME_V->args; 4076 x = args;
4113 v = num_one; 4077 v = num_one;
4114 } 4078 }
4115 else 4079 else
4116 { 4080 {
4117 x = cdr (SCHEME_V->args); 4081 x = cdr (args);
4118 v = nvalue (car (SCHEME_V->args)); 4082 v = nvalue (car (args));
4119 } 4083 }
4120 4084
4121 for (; x != NIL; x = cdr (x)) 4085 for (; x != NIL; x = cdr (x))
4122 { 4086 {
4123 if (ivalue (car (x)) != 0) 4087 if (ivalue (car (x)) != 0)
… …
4127 } 4091 }
4128 4092
4129 s_return (mk_number (SCHEME_A_ v)); 4093 s_return (mk_number (SCHEME_A_ v));
4130 4094
4131 case OP_REM: /* remainder */ 4095 case OP_REM: /* remainder */
4132 v = nvalue (car (SCHEME_V->args)); 4096 v = nvalue (x);
4133 4097
4134 if (ivalue (cadr (SCHEME_V->args)) != 0) 4098 if (ivalue (cadr (args)) != 0)
4135 v = num_rem (v, nvalue (cadr (SCHEME_V->args))); 4099 v = num_rem (v, nvalue (cadr (args)));
4136 else 4100 else
4137 Error_0 ("remainder: division by zero"); 4101 Error_0 ("remainder: division by zero");
4138 4102
4139 s_return (mk_number (SCHEME_A_ v)); 4103 s_return (mk_number (SCHEME_A_ v));
4140 4104
4141 case OP_MOD: /* modulo */ 4105 case OP_MOD: /* modulo */
4142 v = nvalue (car (SCHEME_V->args)); 4106 v = nvalue (x);
4143 4107
4144 if (ivalue (cadr (SCHEME_V->args)) != 0) 4108 if (ivalue (cadr (args)) != 0)
4145 v = num_mod (v, nvalue (cadr (SCHEME_V->args))); 4109 v = num_mod (v, nvalue (cadr (args)));
4146 else 4110 else
4147 Error_0 ("modulo: division by zero"); 4111 Error_0 ("modulo: division by zero");
4148 4112
4149 s_return (mk_number (SCHEME_A_ v)); 4113 s_return (mk_number (SCHEME_A_ v));
4150 4114
4151 case OP_CAR: /* car */ 4115 case OP_CAR: /* car */
4152 s_return (caar (SCHEME_V->args)); 4116 s_return (caar (args));
4153 4117
4154 case OP_CDR: /* cdr */ 4118 case OP_CDR: /* cdr */
4155 s_return (cdar (SCHEME_V->args)); 4119 s_return (cdar (args));
4156 4120
4157 case OP_CONS: /* cons */ 4121 case OP_CONS: /* cons */
4158 set_cdr (SCHEME_V->args, cadr (SCHEME_V->args)); 4122 set_cdr (args, cadr (args));
4159 s_return (SCHEME_V->args); 4123 s_return (args);
4160 4124
4161 case OP_SETCAR: /* set-car! */ 4125 case OP_SETCAR: /* set-car! */
4162 if (!is_immutable (car (SCHEME_V->args))) 4126 if (!is_immutable (x))
4163 { 4127 {
4164 set_car (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4128 set_car (x, cadr (args));
4165 s_return (car (SCHEME_V->args)); 4129 s_return (car (args));
4166 } 4130 }
4167 else 4131 else
4168 Error_0 ("set-car!: unable to alter immutable pair"); 4132 Error_0 ("set-car!: unable to alter immutable pair");
4169 4133
4170 case OP_SETCDR: /* set-cdr! */ 4134 case OP_SETCDR: /* set-cdr! */
4171 if (!is_immutable (car (SCHEME_V->args))) 4135 if (!is_immutable (x))
4172 { 4136 {
4173 set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4137 set_cdr (x, cadr (args));
4174 s_return (car (SCHEME_V->args)); 4138 s_return (car (args));
4175 } 4139 }
4176 else 4140 else
4177 Error_0 ("set-cdr!: unable to alter immutable pair"); 4141 Error_0 ("set-cdr!: unable to alter immutable pair");
4178 4142
4179 case OP_CHAR2INT: /* char->integer */ 4143 case OP_CHAR2INT: /* char->integer */
4180 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4144 s_return (mk_integer (SCHEME_A_ ivalue (x)));
4181 4145
4182 case OP_INT2CHAR: /* integer->char */ 4146 case OP_INT2CHAR: /* integer->char */
4183 s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4147 s_return (mk_character (SCHEME_A_ ivalue (x)));
4184 4148
4185 case OP_CHARUPCASE: 4149 case OP_CHARUPCASE:
4186 { 4150 {
4187 unsigned char c = ivalue (car (SCHEME_V->args)); 4151 unsigned char c = ivalue (x);
4188 c = toupper (c); 4152 c = toupper (c);
4189 s_return (mk_character (SCHEME_A_ c)); 4153 s_return (mk_character (SCHEME_A_ c));
4190 } 4154 }
4191 4155
4192 case OP_CHARDNCASE: 4156 case OP_CHARDNCASE:
4193 { 4157 {
4194 unsigned char c = ivalue (car (SCHEME_V->args)); 4158 unsigned char c = ivalue (x);
4195 c = tolower (c); 4159 c = tolower (c);
4196 s_return (mk_character (SCHEME_A_ c)); 4160 s_return (mk_character (SCHEME_A_ c));
4197 } 4161 }
4198 4162
4199 case OP_STR2SYM: /* string->symbol */ 4163 case OP_STR2SYM: /* string->symbol */
4200 s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); 4164 s_return (mk_symbol (SCHEME_A_ strvalue (x)));
4201 4165
4202 case OP_STR2ATOM: /* string->atom */ 4166 case OP_STR2ATOM: /* string->atom */
4203 { 4167 {
4204 char *s = strvalue (car (SCHEME_V->args)); 4168 char *s = strvalue (x);
4205 long pf = 0; 4169 long pf = 0;
4206 4170
4207 if (cdr (SCHEME_V->args) != NIL) 4171 if (cdr (args) != NIL)
4208 { 4172 {
4209 /* we know cadr(SCHEME_V->args) is a natural number */ 4173 /* we know cadr(args) is a natural number */
4210 /* see if it is 2, 8, 10, or 16, or error */ 4174 /* see if it is 2, 8, 10, or 16, or error */
4211 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4175 pf = ivalue_unchecked (cadr (args));
4212 4176
4213 if (pf == 16 || pf == 10 || pf == 8 || pf == 2) 4177 if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4214 { 4178 {
4215 /* base is OK */ 4179 /* base is OK */
4216 } 4180 }
4217 else 4181 else
4218 pf = -1; 4182 pf = -1;
4219 } 4183 }
4220 4184
4221 if (pf < 0) 4185 if (pf < 0)
4222 Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); 4186 Error_1 ("string->atom: bad base:", cadr (args));
4223 else if (*s == '#') /* no use of base! */ 4187 else if (*s == '#') /* no use of base! */
4224 s_return (mk_sharp_const (SCHEME_A_ s + 1)); 4188 s_return (mk_sharp_const (SCHEME_A_ s + 1));
4225 else 4189 else
4226 { 4190 {
4227 if (pf == 0 || pf == 10) 4191 if (pf == 0 || pf == 10)
… …
4238 } 4202 }
4239 } 4203 }
4240 } 4204 }
4241 4205
4242 case OP_SYM2STR: /* symbol->string */ 4206 case OP_SYM2STR: /* symbol->string */
4243 x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args))); 4207 x = mk_string (SCHEME_A_ symname (x));
4244 setimmutable (x); 4208 setimmutable (x);
4245 s_return (x); 4209 s_return (x);
4246 4210
4247 case OP_ATOM2STR: /* atom->string */ 4211 case OP_ATOM2STR: /* atom->string */
4248 { 4212 {
4249 long pf = 0; 4213 long pf = 0;
4250 4214
4251 x = car (SCHEME_V->args);
4252
4253 if (cdr (SCHEME_V->args) != NIL) 4215 if (cdr (args) != NIL)
4254 { 4216 {
4255 /* we know cadr(SCHEME_V->args) is a natural number */ 4217 /* we know cadr(args) is a natural number */
4256 /* see if it is 2, 8, 10, or 16, or error */ 4218 /* see if it is 2, 8, 10, or 16, or error */
4257 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4219 pf = ivalue_unchecked (cadr (args));
4258 4220
4259 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) 4221 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4260 { 4222 {
4261 /* base is OK */ 4223 /* base is OK */
4262 } 4224 }
4263 else 4225 else
4264 pf = -1; 4226 pf = -1;
4265 } 4227 }
4266 4228
4267 if (pf < 0) 4229 if (pf < 0)
4268 Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); 4230 Error_1 ("atom->string: bad base:", cadr (args));
4269 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) 4231 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4270 { 4232 {
4271 char *p; 4233 char *p;
4272 int len; 4234 int len;
4273 4235
… …
4281 case OP_MKSTRING: /* make-string */ 4243 case OP_MKSTRING: /* make-string */
4282 { 4244 {
4283 int fill = ' '; 4245 int fill = ' ';
4284 int len; 4246 int len;
4285 4247
4286 len = ivalue (car (SCHEME_V->args)); 4248 len = ivalue (x);
4287 4249
4288 if (cdr (SCHEME_V->args) != NIL) 4250 if (cdr (args) != NIL)
4289 fill = charvalue (cadr (SCHEME_V->args)); 4251 fill = charvalue (cadr (args));
4290 4252
4291 s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); 4253 s_return (mk_empty_string (SCHEME_A_ len, (char) fill));
4292 } 4254 }
4293 4255
4294 case OP_STRLEN: /* string-length */ 4256 case OP_STRLEN: /* string-length */
4295 s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args)))); 4257 s_return (mk_integer (SCHEME_A_ strlength (x)));
4296 4258
4297 case OP_STRREF: /* string-ref */ 4259 case OP_STRREF: /* string-ref */
4298 { 4260 {
4299 char *str; 4261 char *str;
4300 int index; 4262 int index;
4301 4263
4302 str = strvalue (car (SCHEME_V->args)); 4264 str = strvalue (x);
4303 4265
4304 index = ivalue (cadr (SCHEME_V->args)); 4266 index = ivalue (cadr (args));
4305 4267
4306 if (index >= strlength (car (SCHEME_V->args))) 4268 if (index >= strlength (x))
4307 Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); 4269 Error_1 ("string-ref: out of bounds:", cadr (args));
4308 4270
4309 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); 4271 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index]));
4310 } 4272 }
4311 4273
4312 case OP_STRSET: /* string-set! */ 4274 case OP_STRSET: /* string-set! */
4313 { 4275 {
4314 char *str; 4276 char *str;
4315 int index; 4277 int index;
4316 int c; 4278 int c;
4317 4279
4318 if (is_immutable (car (SCHEME_V->args))) 4280 if (is_immutable (x))
4319 Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); 4281 Error_1 ("string-set!: unable to alter immutable string:", x);
4320 4282
4321 str = strvalue (car (SCHEME_V->args)); 4283 str = strvalue (x);
4322 4284
4323 index = ivalue (cadr (SCHEME_V->args)); 4285 index = ivalue (cadr (args));
4324 4286
4325 if (index >= strlength (car (SCHEME_V->args))) 4287 if (index >= strlength (x))
4326 Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); 4288 Error_1 ("string-set!: out of bounds:", cadr (args));
4327 4289
4328 c = charvalue (caddr (SCHEME_V->args)); 4290 c = charvalue (caddr (args));
4329 4291
4330 str[index] = (char) c; 4292 str[index] = (char)c;
4331 s_return (car (SCHEME_V->args)); 4293 s_return (car (args));
4332 } 4294 }
4333 4295
4334 case OP_STRAPPEND: /* string-append */ 4296 case OP_STRAPPEND: /* string-append */
4335 { 4297 {
4336 /* in 1.29 string-append was in Scheme in init.scm but was too slow */ 4298 /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4337 int len = 0; 4299 int len = 0;
4338 pointer newstr; 4300 pointer newstr;
4339 char *pos; 4301 char *pos;
4340 4302
4341 /* compute needed length for new string */ 4303 /* compute needed length for new string */
4342 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4304 for (x = args; x != NIL; x = cdr (x))
4343 len += strlength (car (x)); 4305 len += strlength (car (x));
4344 4306
4345 newstr = mk_empty_string (SCHEME_A_ len, ' '); 4307 newstr = mk_empty_string (SCHEME_A_ len, ' ');
4346 4308
4347 /* store the contents of the argument strings into the new string */ 4309 /* store the contents of the argument strings into the new string */
4348 for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) 4310 for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4349 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4311 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4350 4312
4351 s_return (newstr); 4313 s_return (newstr);
4352 } 4314 }
4353 4315
… …
4356 char *str; 4318 char *str;
4357 int index0; 4319 int index0;
4358 int index1; 4320 int index1;
4359 int len; 4321 int len;
4360 4322
4361 str = strvalue (car (SCHEME_V->args)); 4323 str = strvalue (x);
4362 4324
4363 index0 = ivalue (cadr (SCHEME_V->args)); 4325 index0 = ivalue (cadr (args));
4364 4326
4365 if (index0 > strlength (car (SCHEME_V->args))) 4327 if (index0 > strlength (x))
4366 Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); 4328 Error_1 ("substring: start out of bounds:", cadr (args));
4367 4329
4368 if (cddr (SCHEME_V->args) != NIL) 4330 if (cddr (args) != NIL)
4369 { 4331 {
4370 index1 = ivalue (caddr (SCHEME_V->args)); 4332 index1 = ivalue (caddr (args));
4371 4333
4372 if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) 4334 if (index1 > strlength (x) || index1 < index0)
4373 Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); 4335 Error_1 ("substring: end out of bounds:", caddr (args));
4374 } 4336 }
4375 else 4337 else
4376 index1 = strlength (car (SCHEME_V->args)); 4338 index1 = strlength (x);
4377 4339
4378 len = index1 - index0; 4340 len = index1 - index0;
4379 x = mk_empty_string (SCHEME_A_ len, ' '); 4341 x = mk_empty_string (SCHEME_A_ len, ' ');
4380 memcpy (strvalue (x), str + index0, len); 4342 memcpy (strvalue (x), str + index0, len);
4381 strvalue (x)[len] = 0; 4343 strvalue (x)[len] = 0;
… …
4385 4347
4386 case OP_VECTOR: /* vector */ 4348 case OP_VECTOR: /* vector */
4387 { 4349 {
4388 int i; 4350 int i;
4389 pointer vec; 4351 pointer vec;
4390 int len = list_length (SCHEME_A_ SCHEME_V->args); 4352 int len = list_length (SCHEME_A_ args);
4391 4353
4392 if (len < 0) 4354 if (len < 0)
4393 Error_1 ("vector: not a proper list:", SCHEME_V->args); 4355 Error_1 ("vector: not a proper list:", args);
4394 4356
4395 vec = mk_vector (SCHEME_A_ len); 4357 vec = mk_vector (SCHEME_A_ len);
4396 4358
4397#if USE_ERROR_CHECKING 4359#if USE_ERROR_CHECKING
4398 if (SCHEME_V->no_memory) 4360 if (SCHEME_V->no_memory)
4399 s_return (S_SINK); 4361 s_return (S_SINK);
4400#endif 4362#endif
4401 4363
4402 for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++) 4364 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4403 set_vector_elem (vec, i, car (x)); 4365 set_vector_elem (vec, i, car (x));
4404 4366
4405 s_return (vec); 4367 s_return (vec);
4406 } 4368 }
4407 4369
… …
4409 { 4371 {
4410 pointer fill = NIL; 4372 pointer fill = NIL;
4411 int len; 4373 int len;
4412 pointer vec; 4374 pointer vec;
4413 4375
4414 len = ivalue (car (SCHEME_V->args)); 4376 len = ivalue (x);
4415 4377
4416 if (cdr (SCHEME_V->args) != NIL) 4378 if (cdr (args) != NIL)
4417 fill = cadr (SCHEME_V->args); 4379 fill = cadr (args);
4418 4380
4419 vec = mk_vector (SCHEME_A_ len); 4381 vec = mk_vector (SCHEME_A_ len);
4420 4382
4421#if USE_ERROR_CHECKING 4383#if USE_ERROR_CHECKING
4422 if (SCHEME_V->no_memory) 4384 if (SCHEME_V->no_memory)
… …
4428 4390
4429 s_return (vec); 4391 s_return (vec);
4430 } 4392 }
4431 4393
4432 case OP_VECLEN: /* vector-length */ 4394 case OP_VECLEN: /* vector-length */
4433 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args)))); 4395 s_return (mk_integer (SCHEME_A_ veclength (x)));
4434 4396
4435 case OP_VECREF: /* vector-ref */ 4397 case OP_VECREF: /* vector-ref */
4436 { 4398 {
4437 int index; 4399 int index;
4438 4400
4439 index = ivalue (cadr (SCHEME_V->args)); 4401 index = ivalue (cadr (args));
4440 4402
4441 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4403 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4442 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4404 Error_1 ("vector-ref: out of bounds:", cadr (args));
4443 4405
4444 s_return (vector_elem (car (SCHEME_V->args), index)); 4406 s_return (vector_elem (x, index));
4445 } 4407 }
4446 4408
4447 case OP_VECSET: /* vector-set! */ 4409 case OP_VECSET: /* vector-set! */
4448 { 4410 {
4449 int index; 4411 int index;
4450 4412
4451 if (is_immutable (car (SCHEME_V->args))) 4413 if (is_immutable (x))
4452 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4414 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4453 4415
4454 index = ivalue (cadr (SCHEME_V->args)); 4416 index = ivalue (cadr (args));
4455 4417
4456 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4418 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4457 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4419 Error_1 ("vector-set!: out of bounds:", cadr (args));
4458 4420
4459 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4421 set_vector_elem (x, index, caddr (args));
4460 s_return (car (SCHEME_V->args)); 4422 s_return (x);
4461 } 4423 }
4462 } 4424 }
4463 4425
4464 return S_T; 4426 return S_T;
4465} 4427}
… …
4550} 4512}
4551 4513
4552static pointer 4514static pointer
4553opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4515opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4554{ 4516{
4555 pointer x = SCHEME_V->args; 4517 pointer args = SCHEME_V->args;
4556 pointer a = car (x); 4518 pointer a = car (args);
4557 pointer d = cdr (x); 4519 pointer d = cdr (args);
4558 int r; 4520 int r;
4559 4521
4560 switch (op) 4522 switch (op)
4561 { 4523 {
4562 case OP_NOT: /* not */ r = is_false (a) ; break; 4524 case OP_NOT: /* not */ r = is_false (a) ; break;
… …
4596 4558
4597 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break; 4559 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4598 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break; 4560 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4599 case OP_ENVP: /* environment? */ r = is_environment (a) ; break; 4561 case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4600 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break; 4562 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4601 case OP_EQ: /* eq? */ r = a == cadr (x) ; break; 4563 case OP_EQ: /* eq? */ r = a == cadr (args) ; break;
4602 case OP_EQV: /* eqv? */ r = eqv (a, cadr (x)) ; break; 4564 case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break;
4603 } 4565 }
4604 4566
4605 s_retbool (r); 4567 s_retbool (r);
4606} 4568}
4607 4569
4608static pointer 4570static pointer
4609opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4571opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4610{ 4572{
4573 pointer args = SCHEME_V->args;
4574 pointer a = car (args);
4611 pointer x, y; 4575 pointer x, y;
4612 4576
4613 switch (op) 4577 switch (op)
4614 { 4578 {
4615 case OP_FORCE: /* force */ 4579 case OP_FORCE: /* force */
4616 SCHEME_V->code = car (SCHEME_V->args); 4580 SCHEME_V->code = a;
4617 4581
4618 if (is_promise (SCHEME_V->code)) 4582 if (is_promise (SCHEME_V->code))
4619 { 4583 {
4620 /* Should change type to closure here */ 4584 /* Should change type to closure here */
4621 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code); 4585 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
… …
4642 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4606 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4643 SCHEME_V->outport = cadr (SCHEME_V->args); 4607 SCHEME_V->outport = cadr (SCHEME_V->args);
4644 } 4608 }
4645 } 4609 }
4646 4610
4647 SCHEME_V->args = car (SCHEME_V->args); 4611 SCHEME_V->args = a;
4648 4612
4649 if (op == OP_WRITE) 4613 if (op == OP_WRITE)
4650 SCHEME_V->print_flag = 1; 4614 SCHEME_V->print_flag = 1;
4651 else 4615 else
4652 SCHEME_V->print_flag = 0; 4616 SCHEME_V->print_flag = 0;
4653 4617
4654 s_goto (OP_P0LIST); 4618 s_goto (OP_P0LIST);
4655 4619
4656 case OP_NEWLINE: /* newline */ 4620 case OP_NEWLINE: /* newline */
4657 if (is_pair (SCHEME_V->args)) 4621 if (is_pair (args))
4658 { 4622 {
4659 if (car (SCHEME_V->args) != SCHEME_V->outport) 4623 if (a != SCHEME_V->outport)
4660 { 4624 {
4661 x = cons (SCHEME_V->outport, NIL); 4625 x = cons (SCHEME_V->outport, NIL);
4662 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4626 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4663 SCHEME_V->outport = car (SCHEME_V->args); 4627 SCHEME_V->outport = a;
4664 } 4628 }
4665 } 4629 }
4666 4630
4667 putstr (SCHEME_A_ "\n"); 4631 putstr (SCHEME_A_ "\n");
4668 s_return (S_T); 4632 s_return (S_T);
4669#endif 4633#endif
4670 4634
4671 case OP_ERR0: /* error */ 4635 case OP_ERR0: /* error */
4672 SCHEME_V->retcode = -1; 4636 SCHEME_V->retcode = -1;
4673 4637
4674 if (!is_string (car (SCHEME_V->args))) 4638 if (!is_string (a))
4675 { 4639 {
4676 SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args); 4640 args = cons (mk_string (SCHEME_A_ " -- "), args);
4677 setimmutable (car (SCHEME_V->args)); 4641 setimmutable (car (args));
4678 } 4642 }
4679 4643
4680 putstr (SCHEME_A_ "Error: "); 4644 putstr (SCHEME_A_ "Error: ");
4681 putstr (SCHEME_A_ strvalue (car (SCHEME_V->args))); 4645 putstr (SCHEME_A_ strvalue (car (args)));
4682 SCHEME_V->args = cdr (SCHEME_V->args); 4646 SCHEME_V->args = cdr (args);
4683 s_goto (OP_ERR1); 4647 s_goto (OP_ERR1);
4684 4648
4685 case OP_ERR1: /* error */ 4649 case OP_ERR1: /* error */
4686 putstr (SCHEME_A_ " "); 4650 putstr (SCHEME_A_ " ");
4687 4651
4688 if (SCHEME_V->args != NIL) 4652 if (args != NIL)
4689 { 4653 {
4690 s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL); 4654 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4691 SCHEME_V->args = car (SCHEME_V->args); 4655 SCHEME_V->args = a;
4692 SCHEME_V->print_flag = 1; 4656 SCHEME_V->print_flag = 1;
4693 s_goto (OP_P0LIST); 4657 s_goto (OP_P0LIST);
4694 } 4658 }
4695 else 4659 else
4696 { 4660 {
… …
4701 else 4665 else
4702 return NIL; 4666 return NIL;
4703 } 4667 }
4704 4668
4705 case OP_REVERSE: /* reverse */ 4669 case OP_REVERSE: /* reverse */
4706 s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); 4670 s_return (reverse (SCHEME_A_ a));
4707 4671
4708 case OP_LIST_STAR: /* list* */ 4672 case OP_LIST_STAR: /* list* */
4709 s_return (list_star (SCHEME_A_ SCHEME_V->args)); 4673 s_return (list_star (SCHEME_A_ SCHEME_V->args));
4710 4674
4711 case OP_APPEND: /* append */ 4675 case OP_APPEND: /* append */
4712 x = NIL; 4676 x = NIL;
4713 y = SCHEME_V->args; 4677 y = args;
4714 4678
4715 if (y == x) 4679 if (y == x)
4716 s_return (x); 4680 s_return (x);
4717 4681
4718 /* cdr() in the while condition is not a typo. If car() */ 4682 /* cdr() in the while condition is not a typo. If car() */
… …
4729 s_return (reverse_in_place (SCHEME_A_ car (y), x)); 4693 s_return (reverse_in_place (SCHEME_A_ car (y), x));
4730 4694
4731#if USE_PLIST 4695#if USE_PLIST
4732 4696
4733 case OP_PUT: /* put */ 4697 case OP_PUT: /* put */
4734 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4698 if (!hasprop (a) || !hasprop (cadr (args)))
4735 Error_0 ("illegal use of put"); 4699 Error_0 ("illegal use of put");
4736 4700
4737 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4701 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4738 { 4702 {
4739 if (caar (x) == y) 4703 if (caar (x) == y)
4740 break; 4704 break;
4741 } 4705 }
4742 4706
4743 if (x != NIL) 4707 if (x != NIL)
4744 cdar (x) = caddr (SCHEME_V->args); 4708 cdar (x) = caddr (args);
4745 else 4709 else
4746 symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args))); 4710 symprop (a) = cons (cons (y, caddr (args)), symprop (a));
4747 4711
4748 s_return (S_T); 4712 s_return (S_T);
4749 4713
4750 case OP_GET: /* get */ 4714 case OP_GET: /* get */
4751 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4715 if (!hasprop (a) || !hasprop (cadr (args)))
4752 Error_0 ("illegal use of get"); 4716 Error_0 ("illegal use of get");
4753 4717
4754 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4718 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4755 if (caar (x) == y) 4719 if (caar (x) == y)
4756 break; 4720 break;
4757 4721
4758 if (x != NIL) 4722 if (x != NIL)
4759 s_return (cdar (x)); 4723 s_return (cdar (x));
… …
4761 s_return (NIL); 4725 s_return (NIL);
4762 4726
4763#endif /* USE_PLIST */ 4727#endif /* USE_PLIST */
4764 4728
4765 case OP_QUIT: /* quit */ 4729 case OP_QUIT: /* quit */
4766 if (is_pair (SCHEME_V->args)) 4730 if (is_pair (args))
4767 SCHEME_V->retcode = ivalue (car (SCHEME_V->args)); 4731 SCHEME_V->retcode = ivalue (a);
4768 4732
4769 return NIL; 4733 return NIL;
4770 4734
4771 case OP_GC: /* gc */ 4735 case OP_GC: /* gc */
4772 gc (SCHEME_A_ NIL, NIL); 4736 gc (SCHEME_A_ NIL, NIL);
… …
4774 4738
4775 case OP_GCVERB: /* gc-verbose */ 4739 case OP_GCVERB: /* gc-verbose */
4776 { 4740 {
4777 int was = SCHEME_V->gc_verbose; 4741 int was = SCHEME_V->gc_verbose;
4778 4742
4779 SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F); 4743 SCHEME_V->gc_verbose = (a != S_F);
4780 s_retbool (was); 4744 s_retbool (was);
4781 } 4745 }
4782 4746
4783 case OP_NEWSEGMENT: /* new-segment */ 4747 case OP_NEWSEGMENT: /* new-segment */
4784 if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args))) 4748 if (!is_pair (args) || !is_number (a))
4785 Error_0 ("new-segment: argument must be a number"); 4749 Error_0 ("new-segment: argument must be a number");
4786 4750
4787 alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args))); 4751 alloc_cellseg (SCHEME_A_ (int)ivalue (a));
4788 4752
4789 s_return (S_T); 4753 s_return (S_T);
4790 4754
4791 case OP_OBLIST: /* oblist */ 4755 case OP_OBLIST: /* oblist */
4792 s_return (oblist_all_symbols (SCHEME_A)); 4756 s_return (oblist_all_symbols (SCHEME_A));
… …
4819 case OP_OPEN_INOUTFILE: 4783 case OP_OPEN_INOUTFILE:
4820 prop = port_input | port_output; 4784 prop = port_input | port_output;
4821 break; 4785 break;
4822 } 4786 }
4823 4787
4824 p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); 4788 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4825 4789
4826 if (p == NIL) 4790 if (p == NIL)
4827 s_return (S_F); 4791 s_return (S_F);
4828 4792
4829 s_return (p); 4793 s_return (p);
… …
4846 case OP_OPEN_INOUTSTRING: 4810 case OP_OPEN_INOUTSTRING:
4847 prop = port_input | port_output; 4811 prop = port_input | port_output;
4848 break; 4812 break;
4849 } 4813 }
4850 4814
4851 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4815 p = port_from_string (SCHEME_A_ strvalue (a),
4852 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); 4816 strvalue (a) + strlength (a), prop);
4853 4817
4854 if (p == NIL) 4818 if (p == NIL)
4855 s_return (S_F); 4819 s_return (S_F);
4856 4820
4857 s_return (p); 4821 s_return (p);
… …
4859 4823
4860 case OP_OPEN_OUTSTRING: /* open-output-string */ 4824 case OP_OPEN_OUTSTRING: /* open-output-string */
4861 { 4825 {
4862 pointer p; 4826 pointer p;
4863 4827
4864 if (car (SCHEME_V->args) == NIL) 4828 if (a == NIL)
4865 { 4829 {
4866 p = port_from_scratch (SCHEME_A); 4830 p = port_from_scratch (SCHEME_A);
4867 4831
4868 if (p == NIL) 4832 if (p == NIL)
4869 s_return (S_F); 4833 s_return (S_F);
4870 } 4834 }
4871 else 4835 else
4872 { 4836 {
4873 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4837 p = port_from_string (SCHEME_A_ strvalue (a),
4874 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); 4838 strvalue (a) + strlength (a), port_output);
4875 4839
4876 if (p == NIL) 4840 if (p == NIL)
4877 s_return (S_F); 4841 s_return (S_F);
4878 } 4842 }
4879 4843
… …
4882 4846
4883 case OP_GET_OUTSTRING: /* get-output-string */ 4847 case OP_GET_OUTSTRING: /* get-output-string */
4884 { 4848 {
4885 port *p; 4849 port *p;
4886 4850
4887 if ((p = car (SCHEME_V->args)->object.port)->kind & port_string) 4851 if ((p = a->object.port)->kind & port_string)
4888 { 4852 {
4889 off_t size; 4853 off_t size;
4890 char *str; 4854 char *str;
4891 4855
4892 size = p->rep.string.curr - p->rep.string.start + 1; 4856 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4908 } 4872 }
4909 4873
4910# endif 4874# endif
4911 4875
4912 case OP_CLOSE_INPORT: /* close-input-port */ 4876 case OP_CLOSE_INPORT: /* close-input-port */
4913 port_close (SCHEME_A_ car (SCHEME_V->args), port_input); 4877 port_close (SCHEME_A_ a, port_input);
4914 s_return (S_T); 4878 s_return (S_T);
4915 4879
4916 case OP_CLOSE_OUTPORT: /* close-output-port */ 4880 case OP_CLOSE_OUTPORT: /* close-output-port */
4917 port_close (SCHEME_A_ car (SCHEME_V->args), port_output); 4881 port_close (SCHEME_A_ a, port_output);
4918 s_return (S_T); 4882 s_return (S_T);
4919#endif 4883#endif
4920 4884
4921 case OP_INT_ENV: /* interaction-environment */ 4885 case OP_INT_ENV: /* interaction-environment */
4922 s_return (SCHEME_V->global_env); 4886 s_return (SCHEME_V->global_env);
… …
5445 { 5409 {
5446 ok = 0; 5410 ok = 0;
5447 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5411 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5448 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5412 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5449 } 5413 }
5450 else if (ecb_excpect_false (n > pcd->max_arity)) 5414 else if (ecb_expect_false (n > pcd->max_arity))
5451 { 5415 {
5452 ok = 0; 5416 ok = 0;
5453 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5417 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5454 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5418 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5455 } 5419 }

Diff Legend

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