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

Comparing microscheme/scheme.c (file contents):
Revision 1.37 by root, Sun Nov 29 05:09:24 2015 UTC vs.
Revision 1.38 by root, Sun Nov 29 13:47:15 2015 UTC

… …
406} 406}
407 407
408INTERFACE char * 408INTERFACE char *
409symname (pointer p) 409symname (pointer p)
410{ 410{
411 return strvalue (car (p)); 411 return strvalue (p);
412} 412}
413 413
414#if USE_PLIST 414#if USE_PLIST
415SCHEME_EXPORT int 415SCHEME_EXPORT int
416hasprop (pointer p) 416hasprop (pointer p)
… …
440} 440}
441 441
442INTERFACE char * 442INTERFACE char *
443syntaxname (pointer p) 443syntaxname (pointer p)
444{ 444{
445 return strvalue (car (p)); 445 return strvalue (p);
446} 446}
447 447
448#define procnum(p) ivalue_unchecked (p) 448#define procnum(p) ivalue_unchecked (p)
449static const char *procname (pointer x); 449static const char *procname (pointer x);
450 450
… …
1099static pointer 1099static pointer
1100generate_symbol (SCHEME_P_ const char *name) 1100generate_symbol (SCHEME_P_ const char *name)
1101{ 1101{
1102 pointer x = mk_string (SCHEME_A_ name); 1102 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x); 1103 setimmutable (x);
1104 x = immutable_cons (x, NIL);
1105 set_typeflag (x, T_SYMBOL); 1104 set_typeflag (x, T_SYMBOL | T_ATOM);
1106 return x; 1105 return x;
1107} 1106}
1108 1107
1109#ifndef USE_OBJECT_LIST 1108#ifndef USE_OBJECT_LIST
1110 1109
… …
2476 } 2475 }
2477 2476
2478 putcharacter (SCHEME_A_ '"'); 2477 putcharacter (SCHEME_A_ '"');
2479} 2478}
2480 2479
2481
2482/* print atoms */ 2480/* print atoms */
2483static void 2481static void
2484printatom (SCHEME_P_ pointer l, int f) 2482printatom (SCHEME_P_ pointer l, int f)
2485{ 2483{
2486 char *p; 2484 char *p;
2487 int len; 2485 int len;
2488 2486
2489 atom2str (SCHEME_A_ l, f, &p, &len); 2487 atom2str (SCHEME_A_ l, f, &p, &len);
2490 putchars (SCHEME_A_ p, len); 2488 putchars (SCHEME_A_ p, len);
2491} 2489}
2492
2493 2490
2494/* Uses internal buffer unless string pointer is already available */ 2491/* Uses internal buffer unless string pointer is already available */
2495static void 2492static void
2496atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2493atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2497{ 2494{
… …
2658#endif 2655#endif
2659 } 2656 }
2660 else if (is_continuation (l)) 2657 else if (is_continuation (l))
2661 p = "#<CONTINUATION>"; 2658 p = "#<CONTINUATION>";
2662 else 2659 else
2660 {
2661#if USE_PRINTF
2662 p = SCHEME_V->strbuff;
2663 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2664#else
2663 p = "#<ERROR>"; 2665 p = "#<ERROR>";
2666#endif
2667 }
2664 2668
2665 *pp = p; 2669 *pp = p;
2666 *plen = strlen (p); 2670 *plen = strlen (p);
2667} 2671}
2668 2672
… …
3379 } 3383 }
3380 else 3384 else
3381 s_return (SCHEME_V->code); 3385 s_return (SCHEME_V->code);
3382 3386
3383 case OP_E0ARGS: /* eval arguments */ 3387 case OP_E0ARGS: /* eval arguments */
3384 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3388 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3385 { 3389 {
3386 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3390 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3387 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3391 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3388 SCHEME_V->code = SCHEME_V->value; 3392 SCHEME_V->code = SCHEME_V->value;
3389 s_goto (OP_APPLY); 3393 s_goto (OP_APPLY);
… …
3650 case OP_LET2: /* let */ 3654 case OP_LET2: /* let */
3651 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3655 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3652 3656
3653 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 3657 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3654 y != NIL; x = cdr (x), y = cdr (y)) 3658 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 }
3655 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3664 //new_slot_in_env (SCHEME_A_ caar (x), car (y));
3656 3665
3657 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3666 if (is_symbol (car (SCHEME_V->code))) /* named let */
3658 { 3667 {
3659 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 3668 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3660 { 3669 {
… …
5221 5230
5222 case OP_CLOSUREP: /* closure? */ 5231 case OP_CLOSUREP: /* closure? */
5223 /* 5232 /*
5224 * Note, macro object is also a closure. 5233 * Note, macro object is also a closure.
5225 * Therefore, (closure? <#MACRO>) ==> #t 5234 * Therefore, (closure? <#MACRO>) ==> #t
5235 * (schmorp) well, obviously not, fix? TODO
5226 */ 5236 */
5227 s_retbool (is_closure (a)); 5237 s_retbool (is_closure (a));
5228 5238
5229 case OP_MACROP: /* macro? */ 5239 case OP_MACROP: /* macro? */
5230 s_retbool (is_macro (a)); 5240 s_retbool (is_macro (a));
… …
5471 5481
5472/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5482/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5473static int 5483static int
5474syntaxnum (pointer p) 5484syntaxnum (pointer p)
5475{ 5485{
5476 const char *s = strvalue (car (p)); 5486 const char *s = strvalue (p);
5477 5487
5478 switch (strlength (car (p))) 5488 switch (strlength (p))
5479 { 5489 {
5480 case 2: 5490 case 2:
5481 if (s[0] == 'i') 5491 if (s[0] == 'i')
5482 return OP_IF0; /* if */ 5492 return OP_IF0; /* if */
5483 else 5493 else
… …
5919# endif 5929# endif
5920 int fin; 5930 int fin;
5921 char *file_name = InitFile; 5931 char *file_name = InitFile;
5922 int retcode; 5932 int retcode;
5923 int isfile = 1; 5933 int isfile = 1;
5934 system ("ps v $PPID");//D
5924 5935
5925 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5936 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5926 { 5937 {
5927 xwrstr ("Usage: tinyscheme -?\n"); 5938 xwrstr ("Usage: tinyscheme -?\n");
5928 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 5939 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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