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.40 by root, Mon Nov 30 05:19:01 2015 UTC

… …
74 TOK_SHARP_CONST, 74 TOK_SHARP_CONST,
75 TOK_VEC 75 TOK_VEC
76}; 76};
77 77
78#define BACKQUOTE '`' 78#define BACKQUOTE '`'
79#define DELIMITERS "()\";\f\t\v\n\r " 79#define WHITESPACE " \t\r\n\v\f"
80#define DELIMITERS "()\";" WHITESPACE
80 81
81#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 82#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
82#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 83#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
83#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 84#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
84#define S_SINK (&SCHEME_V->xsink) 85#define S_SINK (&SCHEME_V->xsink)
… …
1688 1689
1689static void 1690static void
1690finalize_cell (SCHEME_P_ pointer a) 1691finalize_cell (SCHEME_P_ pointer a)
1691{ 1692{
1692 /* TODO, fast bitmap check? */ 1693 /* TODO, fast bitmap check? */
1693 if (is_string (a)) 1694 if (is_string (a) || is_symbol (a))
1694 free (strvalue (a)); 1695 free (strvalue (a));
1695 else if (is_vector (a)) 1696 else if (is_vector (a))
1696 free (vecvalue (a)); 1697 free (vecvalue (a));
1697#if USE_PORTS 1698#if USE_PORTS
1698 else if (is_port (a)) 1699 else if (is_port (a))
… …
2264 2265
2265/* check c is in chars */ 2266/* check c is in chars */
2266ecb_inline int 2267ecb_inline int
2267is_one_of (const char *s, int c) 2268is_one_of (const char *s, int c)
2268{ 2269{
2269 if (c == EOF)
2270 return 1;
2271
2272 return !!strchr (s, c); 2270 return c == EOF || !!strchr (s, c);
2273} 2271}
2274 2272
2275/* skip white characters */ 2273/* skip white characters */
2276ecb_inline int 2274ecb_inline int
2277skipspace (SCHEME_P) 2275skipspace (SCHEME_P)
… …
2284#if SHOW_ERROR_LINE 2282#if SHOW_ERROR_LINE
2285 if (c == '\n') 2283 if (c == '\n')
2286 curr_line++; 2284 curr_line++;
2287#endif 2285#endif
2288 } 2286 }
2289 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2287 while (is_one_of (WHITESPACE, c));
2290 2288
2291 /* record it */ 2289 /* record it */
2292#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2293 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2291 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2294 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2292 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
… …
2324 return TOK_RPAREN; 2322 return TOK_RPAREN;
2325 2323
2326 case '.': 2324 case '.':
2327 c = inchar (SCHEME_A); 2325 c = inchar (SCHEME_A);
2328 2326
2329 if (is_one_of (" \n\t", c)) 2327 if (is_one_of (WHITESPACE, c))
2330 return TOK_DOT; 2328 return TOK_DOT;
2331 else 2329 else
2332 { 2330 {
2333 backchar (SCHEME_A_ c); 2331 backchar (SCHEME_A_ c);
2334 return TOK_DOTATOM; 2332 return TOK_DOTATOM;
… …
2942#endif /* USE_ALIST_ENV else */ 2940#endif /* USE_ALIST_ENV else */
2943 2941
2944ecb_inline void 2942ecb_inline void
2945new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2943new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2946{ 2944{
2945 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2947 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2946 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2948} 2947}
2949 2948
2950ecb_inline void 2949ecb_inline void
2951set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2950set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3243 3242
3244#endif 3243#endif
3245 3244
3246#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3247 3246
3247#if 1
3248static int
3249debug (SCHEME_P_ int indent, pointer x)
3250{
3251 int c;
3252
3253 if (is_syntax (x))
3254 {
3255 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3256 return 8 + 8;
3257 }
3258
3259 if (x == NIL)
3260 {
3261 printf ("%*sNIL\n", indent, "");
3262 return 3;
3263 }
3264
3265 switch (type (x))
3266 {
3267 case T_INTEGER:
3268 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3269 return 32+8;
3270
3271 case T_SYMBOL:
3272 printf ("%*sS<%s>\n", indent, "", symname (x));
3273 return 24+8;
3274
3275 case T_CLOSURE:
3276 printf ("%*sS<%s>\n", indent, "", "closure");
3277 debug (SCHEME_A_ indent + 3, cdr(x));
3278 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3279
3280 case T_PAIR:
3281 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3282 c = debug (SCHEME_A_ indent + 3, car (x));
3283 c += debug (SCHEME_A_ indent + 3, cdr (x));
3284 return c + 1;
3285
3286 case T_PORT:
3287 printf ("%*sS<%s>\n", indent, "", "port");
3288 return 24+8;
3289
3290 case T_VECTOR:
3291 printf ("%*sS<%s>\n", indent, "", "vector");
3292 return 24+8;
3293
3294 case T_ENVIRONMENT:
3295 printf ("%*sS<%s>\n", indent, "", "environment");
3296 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3297
3298 default:
3299 printf ("unhandled type %d\n", type (x));
3300 break;
3301 }
3302}
3303#endif
3304
3248static int 3305static int
3249opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3306opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3250{ 3307{
3251 pointer args = SCHEME_V->args; 3308 pointer args = SCHEME_V->args;
3252 pointer x, y; 3309 pointer x, y;
3253 3310
3254 switch (op) 3311 switch (op)
3255 { 3312 {
3313#if 1 //D
3314 case OP_DEBUG:
3315 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3316 printf ("\n");
3317 s_return (S_T);
3318#endif
3256 case OP_LOAD: /* load */ 3319 case OP_LOAD: /* load */
3257 if (file_interactive (SCHEME_A)) 3320 if (file_interactive (SCHEME_A))
3258 { 3321 {
3259 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3322 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))); 3323 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
… …
3654 case OP_LET2: /* let */ 3717 case OP_LET2: /* let */
3655 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3718 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3656 3719
3657 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 3720 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)) 3721 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)); 3722 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3665 3723
3666 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3724 if (is_symbol (car (SCHEME_V->code))) /* named let */
3667 { 3725 {
3668 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 3726 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3669 { 3727 {

Diff Legend

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