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.65 by root, Wed Dec 2 17:01:51 2015 UTC

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

Diff Legend

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