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.35 by root, Sun Nov 29 00:02:21 2015 UTC vs.
Revision 1.43 by root, Mon Nov 30 06:40:57 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 EXPERIMENT 1
22
21#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22#include "malloc.c" 24#include "malloc.c"
23 25
24#define SCHEME_SOURCE 26#define SCHEME_SOURCE
25#include "scheme-private.h" 27#include "scheme-private.h"
… …
74 TOK_SHARP_CONST, 76 TOK_SHARP_CONST,
75 TOK_VEC 77 TOK_VEC
76}; 78};
77 79
78#define BACKQUOTE '`' 80#define BACKQUOTE '`'
79#define DELIMITERS "()\";\f\t\v\n\r " 81#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE
80 83
81#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
82#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
83#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
84#define S_SINK (&SCHEME_V->xsink) 87#define S_SINK (&SCHEME_V->xsink)
… …
406} 409}
407 410
408INTERFACE char * 411INTERFACE char *
409symname (pointer p) 412symname (pointer p)
410{ 413{
411 return strvalue (car (p)); 414 return strvalue (p);
412} 415}
413 416
414#if USE_PLIST 417#if USE_PLIST
418#define symprop(p) cdr(p)
415SCHEME_EXPORT int 419SCHEME_EXPORT int
416hasprop (pointer p) 420hasprop (pointer p)
417{ 421{
418 return typeflag (p) & T_SYMBOL; 422 return typeflag (p) & T_SYMBOL;
419} 423}
420
421# define symprop(p) cdr(p)
422#endif 424#endif
423 425
424INTERFACE int 426INTERFACE int
425is_syntax (pointer p) 427is_syntax (pointer p)
426{ 428{
… …
440} 442}
441 443
442INTERFACE char * 444INTERFACE char *
443syntaxname (pointer p) 445syntaxname (pointer p)
444{ 446{
445 return strvalue (car (p)); 447 return strvalue (p);
446} 448}
447 449
448#define procnum(p) ivalue_unchecked (p) 450#define procnum(p) ivalue_unchecked (p)
449static const char *procname (pointer x); 451static const char *procname (pointer x);
450 452
… …
1092 set_cdr (x, b); 1094 set_cdr (x, b);
1093 1095
1094 return x; 1096 return x;
1095} 1097}
1096 1098
1097/* ========== oblist implementation ========== */
1098
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}
1107
1108/* ========== oblist implementation ========== */
1108 1109
1109#ifndef USE_OBJECT_LIST 1110#ifndef USE_OBJECT_LIST
1110 1111
1111static int 1112static int
1112hash_fn (const char *key, int table_size) 1113hash_fn (const char *key, int table_size)
… …
1354 1355
1355 for (i = start; i < veclength (vec); i++) 1356 for (i = start; i < veclength (vec); i++)
1356 vecvalue (vec)[i] = obj; 1357 vecvalue (vec)[i] = obj;
1357} 1358}
1358 1359
1360INTERFACE void
1361vector_resize (pointer vec, uint32_t newsize, pointer fill)
1362{
1363 uint32_t oldsize = veclength (vec);
1364 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1365 veclength (vec) = newsize;
1366 fill_vector (vec, oldsize, fill);
1367}
1368
1359INTERFACE pointer 1369INTERFACE pointer
1360vector_get (pointer vec, uint32_t ielem) 1370vector_get (pointer vec, uint32_t ielem)
1361{ 1371{
1362 return vecvalue(vec)[ielem]; 1372 return vecvalue(vec)[ielem];
1363} 1373}
… …
1384INTERFACE pointer 1394INTERFACE pointer
1385gensym (SCHEME_P) 1395gensym (SCHEME_P)
1386{ 1396{
1387 pointer x; 1397 pointer x;
1388 char name[40] = "gensym-"; 1398 char name[40] = "gensym-";
1389 xnum (name + 7, SCHEME_V->gensym_cnt); 1399 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1390 1400
1391 return generate_symbol (SCHEME_A_ name); 1401 return generate_symbol (SCHEME_A_ name);
1402}
1403
1404static int
1405is_gensym (SCHEME_P_ pointer x)
1406{
1407 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1392} 1408}
1393 1409
1394/* make symbol or number atom from string */ 1410/* make symbol or number atom from string */
1395static pointer 1411static pointer
1396mk_atom (SCHEME_P_ char *q) 1412mk_atom (SCHEME_P_ char *q)
… …
1680 1696
1681static void 1697static void
1682finalize_cell (SCHEME_P_ pointer a) 1698finalize_cell (SCHEME_P_ pointer a)
1683{ 1699{
1684 /* TODO, fast bitmap check? */ 1700 /* TODO, fast bitmap check? */
1685 if (is_string (a)) 1701 if (is_string (a) || is_symbol (a))
1686 free (strvalue (a)); 1702 free (strvalue (a));
1687 else if (is_vector (a)) 1703 else if (is_vector (a))
1688 free (vecvalue (a)); 1704 free (vecvalue (a));
1689#if USE_PORTS 1705#if USE_PORTS
1690 else if (is_port (a)) 1706 else if (is_port (a))
… …
2256 2272
2257/* check c is in chars */ 2273/* check c is in chars */
2258ecb_inline int 2274ecb_inline int
2259is_one_of (const char *s, int c) 2275is_one_of (const char *s, int c)
2260{ 2276{
2261 if (c == EOF)
2262 return 1;
2263
2264 return !!strchr (s, c); 2277 return c == EOF || !!strchr (s, c);
2265} 2278}
2266 2279
2267/* skip white characters */ 2280/* skip white characters */
2268ecb_inline int 2281ecb_inline int
2269skipspace (SCHEME_P) 2282skipspace (SCHEME_P)
… …
2271 int c, curr_line = 0; 2284 int c, curr_line = 0;
2272 2285
2273 do 2286 do
2274 { 2287 {
2275 c = inchar (SCHEME_A); 2288 c = inchar (SCHEME_A);
2289
2276#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2277 if (c == '\n') 2291 if (ecb_expect_false (c == '\n'))
2278 curr_line++; 2292 curr_line++;
2279#endif 2293#endif
2294
2295 if (ecb_expect_false (c == EOF))
2296 return c;
2280 } 2297 }
2281 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2298 while (is_one_of (WHITESPACE, c));
2282 2299
2283 /* record it */ 2300 /* record it */
2284#if SHOW_ERROR_LINE 2301#if SHOW_ERROR_LINE
2285 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2302 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2286 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2303 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2287#endif 2304#endif
2288 2305
2289 if (c != EOF)
2290 {
2291 backchar (SCHEME_A_ c); 2306 backchar (SCHEME_A_ c);
2292 return 1; 2307 return 1;
2293 }
2294 else
2295 return EOF;
2296} 2308}
2297 2309
2298/* get token */ 2310/* get token */
2299static int 2311static int
2300token (SCHEME_P) 2312token (SCHEME_P)
… …
2316 return TOK_RPAREN; 2328 return TOK_RPAREN;
2317 2329
2318 case '.': 2330 case '.':
2319 c = inchar (SCHEME_A); 2331 c = inchar (SCHEME_A);
2320 2332
2321 if (is_one_of (" \n\t", c)) 2333 if (is_one_of (WHITESPACE, c))
2322 return TOK_DOT; 2334 return TOK_DOT;
2323 else 2335 else
2324 { 2336 {
2325 backchar (SCHEME_A_ c); 2337 backchar (SCHEME_A_ c);
2326 return TOK_DOTATOM; 2338 return TOK_DOTATOM;
… …
2467 } 2479 }
2468 2480
2469 putcharacter (SCHEME_A_ '"'); 2481 putcharacter (SCHEME_A_ '"');
2470} 2482}
2471 2483
2472
2473/* print atoms */ 2484/* print atoms */
2474static void 2485static void
2475printatom (SCHEME_P_ pointer l, int f) 2486printatom (SCHEME_P_ pointer l, int f)
2476{ 2487{
2477 char *p; 2488 char *p;
2478 int len; 2489 int len;
2479 2490
2480 atom2str (SCHEME_A_ l, f, &p, &len); 2491 atom2str (SCHEME_A_ l, f, &p, &len);
2481 putchars (SCHEME_A_ p, len); 2492 putchars (SCHEME_A_ p, len);
2482} 2493}
2483
2484 2494
2485/* Uses internal buffer unless string pointer is already available */ 2495/* Uses internal buffer unless string pointer is already available */
2486static void 2496static void
2487atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2497atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2488{ 2498{
… …
2649#endif 2659#endif
2650 } 2660 }
2651 else if (is_continuation (l)) 2661 else if (is_continuation (l))
2652 p = "#<CONTINUATION>"; 2662 p = "#<CONTINUATION>";
2653 else 2663 else
2664 {
2665#if USE_PRINTF
2666 p = SCHEME_V->strbuff;
2667 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2668#else
2654 p = "#<ERROR>"; 2669 p = "#<ERROR>";
2670#endif
2671 }
2655 2672
2656 *pp = p; 2673 *pp = p;
2657 *plen = strlen (p); 2674 *plen = strlen (p);
2658} 2675}
2659 2676
… …
2929#endif /* USE_ALIST_ENV else */ 2946#endif /* USE_ALIST_ENV else */
2930 2947
2931ecb_inline void 2948ecb_inline void
2932new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2949new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2933{ 2950{
2951 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2934 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2952 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2935} 2953}
2936 2954
2937ecb_inline void 2955ecb_inline void
2938set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2956set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3230 3248
3231#endif 3249#endif
3232 3250
3233#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3251#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3234 3252
3253#if EXPERIMENT
3254static int
3255debug (SCHEME_P_ int indent, pointer x)
3256{
3257 int c;
3258
3259 if (is_syntax (x))
3260 {
3261 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3262 return 8 + 8;
3263 }
3264
3265 if (x == NIL)
3266 {
3267 printf ("%*sNIL\n", indent, "");
3268 return 3;
3269 }
3270
3271 switch (type (x))
3272 {
3273 case T_INTEGER:
3274 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3275 return 32+8;
3276
3277 case T_SYMBOL:
3278 printf ("%*sS<%s>\n", indent, "", symname (x));
3279 return 24+8;
3280
3281 case T_CLOSURE:
3282 printf ("%*sS<%s>\n", indent, "", "closure");
3283 debug (SCHEME_A_ indent + 3, cdr(x));
3284 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3285
3286 case T_PAIR:
3287 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3288 c = debug (SCHEME_A_ indent + 3, car (x));
3289 c += debug (SCHEME_A_ indent + 3, cdr (x));
3290 return c + 1;
3291
3292 case T_PORT:
3293 printf ("%*sS<%s>\n", indent, "", "port");
3294 return 24+8;
3295
3296 case T_VECTOR:
3297 printf ("%*sS<%s>\n", indent, "", "vector");
3298 return 24+8;
3299
3300 case T_ENVIRONMENT:
3301 printf ("%*sS<%s>\n", indent, "", "environment");
3302 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3303
3304 default:
3305 printf ("unhandled type %d\n", type (x));
3306 break;
3307 }
3308}
3309#endif
3310
3235static int 3311static int
3236opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3312opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3237{ 3313{
3238 pointer args = SCHEME_V->args; 3314 pointer args = SCHEME_V->args;
3239 pointer x, y; 3315 pointer x, y;
3240 3316
3241 switch (op) 3317 switch (op)
3242 { 3318 {
3319#if EXPERIMENT //D
3320 case OP_DEBUG:
3321 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3322 printf ("\n");
3323 s_return (S_T);
3324#endif
3243 case OP_LOAD: /* load */ 3325 case OP_LOAD: /* load */
3244 if (file_interactive (SCHEME_A)) 3326 if (file_interactive (SCHEME_A))
3245 { 3327 {
3246 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3328 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3247 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3329 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
… …
3370 } 3452 }
3371 else 3453 else
3372 s_return (SCHEME_V->code); 3454 s_return (SCHEME_V->code);
3373 3455
3374 case OP_E0ARGS: /* eval arguments */ 3456 case OP_E0ARGS: /* eval arguments */
3375 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3457 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3376 { 3458 {
3377 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3459 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3378 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3460 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3379 SCHEME_V->code = SCHEME_V->value; 3461 SCHEME_V->code = SCHEME_V->value;
3380 s_goto (OP_APPLY); 3462 s_goto (OP_APPLY);
… …
4378 } 4460 }
4379 4461
4380 case OP_VECLEN: /* vector-length */ 4462 case OP_VECLEN: /* vector-length */
4381 s_return (mk_integer (SCHEME_A_ veclength (x))); 4463 s_return (mk_integer (SCHEME_A_ veclength (x)));
4382 4464
4465 case OP_VECRESIZE:
4466 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4467 s_return (x);
4468
4383 case OP_VECREF: /* vector-ref */ 4469 case OP_VECREF: /* vector-ref */
4384 { 4470 {
4385 int index = ivalue_unchecked (cadr (args)); 4471 int index = ivalue_unchecked (cadr (args));
4386 4472
4387 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4473 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
… …
4447 pointer d = cdr (args); 4533 pointer d = cdr (args);
4448 int r; 4534 int r;
4449 4535
4450 switch (op) 4536 switch (op)
4451 { 4537 {
4452 case OP_NOT: /* not */ r = is_false (a) ; break; 4538 case OP_NOT: /* not */ r = is_false (a) ; break;
4453 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4539 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4454 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4540 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4455 case OP_NULLP: /* null? */ r = a == NIL ; break; 4541 case OP_NULLP: /* null? */ r = a == NIL ; break;
4456 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4542 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4543 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4457 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4544 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4458 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4545 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4459 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4546 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4460 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4547 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4461 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4548 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4462 4549
4463#if USE_CHAR_CLASSIFIERS 4550#if USE_CHAR_CLASSIFIERS
4464 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4551 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4465 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4552 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4466 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4553 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
… …
4947 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))); 5034 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
4948 5035
4949 case TOK_DOTATOM: 5036 case TOK_DOTATOM:
4950 SCHEME_V->strbuff[0] = '.'; 5037 SCHEME_V->strbuff[0] = '.';
4951 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5038 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5039
5040 case TOK_STRATOM:
5041 x = readstrexp (SCHEME_A_ '|');
5042 //TODO: haven't checked whether the garbage collector could interfere
5043 s_return (mk_atom (SCHEME_A_ strvalue (x)));
4952 5044
4953 case TOK_DQUOTE: 5045 case TOK_DQUOTE:
4954 x = readstrexp (SCHEME_A_ '"'); 5046 x = readstrexp (SCHEME_A_ '"');
4955 5047
4956 if (x == S_F) 5048 if (x == S_F)
… …
5203 5295
5204 case OP_CLOSUREP: /* closure? */ 5296 case OP_CLOSUREP: /* closure? */
5205 /* 5297 /*
5206 * Note, macro object is also a closure. 5298 * Note, macro object is also a closure.
5207 * Therefore, (closure? <#MACRO>) ==> #t 5299 * Therefore, (closure? <#MACRO>) ==> #t
5300 * (schmorp) well, obviously not, fix? TODO
5208 */ 5301 */
5209 s_retbool (is_closure (a)); 5302 s_retbool (is_closure (a));
5210 5303
5211 case OP_MACROP: /* macro? */ 5304 case OP_MACROP: /* macro? */
5212 s_retbool (is_macro (a)); 5305 s_retbool (is_macro (a));
… …
5453 5546
5454/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5547/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5455static int 5548static int
5456syntaxnum (pointer p) 5549syntaxnum (pointer p)
5457{ 5550{
5458 const char *s = strvalue (car (p)); 5551 const char *s = strvalue (p);
5459 5552
5460 switch (strlength (car (p))) 5553 switch (strlength (p))
5461 { 5554 {
5462 case 2: 5555 case 2:
5463 if (s[0] == 'i') 5556 if (s[0] == 'i')
5464 return OP_IF0; /* if */ 5557 return OP_IF0; /* if */
5465 else 5558 else
… …
5901# endif 5994# endif
5902 int fin; 5995 int fin;
5903 char *file_name = InitFile; 5996 char *file_name = InitFile;
5904 int retcode; 5997 int retcode;
5905 int isfile = 1; 5998 int isfile = 1;
5999 system ("ps v $PPID");//D
5906 6000
5907 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6001 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5908 { 6002 {
5909 xwrstr ("Usage: tinyscheme -?\n"); 6003 xwrstr ("Usage: tinyscheme -?\n");
5910 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6004 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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