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.38 by root, Sun Nov 29 13:47:15 2015 UTC vs.
Revision 1.39 by root, Sun Nov 29 14:22:30 2015 UTC

… …
2942#endif /* USE_ALIST_ENV else */ 2942#endif /* USE_ALIST_ENV else */
2943 2943
2944ecb_inline void 2944ecb_inline void
2945new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2945new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2946{ 2946{
2947 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2947 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2948 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2948} 2949}
2949 2950
2950ecb_inline void 2951ecb_inline void
2951set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2952set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3243 3244
3244#endif 3245#endif
3245 3246
3246#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3247#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3247 3248
3249#if 1
3250static int
3251debug (SCHEME_P_ int indent, pointer x)
3252{
3253 int c;
3254
3255 if (is_syntax (x))
3256 {
3257 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3258 return 8 + 8;
3259 }
3260
3261 if (x == NIL)
3262 {
3263 printf ("%*sNIL\n", indent, "");
3264 return 3;
3265 }
3266
3267 switch (type (x))
3268 {
3269 case T_INTEGER:
3270 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3271 return 32+8;
3272
3273 case T_SYMBOL:
3274 printf ("%*sS<%s>\n", indent, "", symname (x));
3275 return 24+8;
3276
3277 case T_CLOSURE:
3278 printf ("%*sS<%s>\n", indent, "", "closure");
3279 debug (SCHEME_A_ indent + 3, cdr(x));
3280 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3281
3282 case T_PAIR:
3283 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3284 c = debug (SCHEME_A_ indent + 3, car (x));
3285 c += debug (SCHEME_A_ indent + 3, cdr (x));
3286 return c + 1;
3287
3288 case T_PORT:
3289 printf ("%*sS<%s>\n", indent, "", "port");
3290 return 24+8;
3291
3292 case T_VECTOR:
3293 printf ("%*sS<%s>\n", indent, "", "vector");
3294 return 24+8;
3295
3296 case T_ENVIRONMENT:
3297 printf ("%*sS<%s>\n", indent, "", "environment");
3298 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3299
3300 default:
3301 printf ("unhandled type %d\n", type (x));
3302 break;
3303 }
3304}
3305#endif
3306
3248static int 3307static int
3249opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3308opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3250{ 3309{
3251 pointer args = SCHEME_V->args; 3310 pointer args = SCHEME_V->args;
3252 pointer x, y; 3311 pointer x, y;
3253 3312
3254 switch (op) 3313 switch (op)
3255 { 3314 {
3315#if 1 //D
3316 case OP_DEBUG:
3317 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3318 printf ("\n");
3319 s_return (S_T);
3320#endif
3256 case OP_LOAD: /* load */ 3321 case OP_LOAD: /* load */
3257 if (file_interactive (SCHEME_A)) 3322 if (file_interactive (SCHEME_A))
3258 { 3323 {
3259 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3324 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3260 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3325 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
… …
3654 case OP_LET2: /* let */ 3719 case OP_LET2: /* let */
3655 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3720 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3656 3721
3657 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 3722 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3658 y != NIL; x = cdr (x), y = cdr (y)) 3723 y != NIL; x = cdr (x), y = cdr (y))
3659 { if (is_pair(caar(x))){debug(SCHEME_A_ 0, SCHEME_V->code);};//D
3660 pointer z = caar (x);
3661 if(is_pair(z)) z = car(z);//D
3662 new_slot_in_env (SCHEME_A_ z, car (y));
3663 }
3664 //new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3724 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3665 3725
3666 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3726 if (is_symbol (car (SCHEME_V->code))) /* named let */
3667 { 3727 {
3668 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 3728 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3669 { 3729 {

Diff Legend

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