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.40 by root, Mon Nov 30 05:19:01 2015 UTC vs.
Revision 1.45 by root, Mon Nov 30 07:44:23 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"
… …
411{ 413{
412 return strvalue (p); 414 return strvalue (p);
413} 415}
414 416
415#if USE_PLIST 417#if USE_PLIST
418#define symprop(p) cdr(p)
416SCHEME_EXPORT int 419SCHEME_EXPORT int
417hasprop (pointer p) 420hasprop (pointer p)
418{ 421{
419 return typeflag (p) & T_SYMBOL; 422 return typeflag (p) & T_SYMBOL;
420} 423}
421
422# define symprop(p) cdr(p)
423#endif 424#endif
424 425
425INTERFACE int 426INTERFACE int
426is_syntax (pointer p) 427is_syntax (pointer p)
427{ 428{
… …
968 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
969 return S_SINK; 970 return S_SINK;
970 971
971 if (SCHEME_V->free_cell == NIL) 972 if (SCHEME_V->free_cell == NIL)
972 { 973 {
973 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 974 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
974 975
975 gc (SCHEME_A_ a, b); 976 gc (SCHEME_A_ a, b);
976 977
977 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
978 { 979 {
… …
1029} 1030}
1030 1031
1031static pointer 1032static pointer
1032get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1033get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1033{ 1034{
1034 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1035 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1035 pointer *e = malloc (len * sizeof (pointer)); 1036 pointer *e = malloc (len * sizeof (pointer));
1036 1037
1037 if (!e && USE_ERROR_CHECKING) 1038 if (!e && USE_ERROR_CHECKING)
1038 return S_SINK; 1039 return S_SINK;
1039 1040
… …
1093 set_cdr (x, b); 1094 set_cdr (x, b);
1094 1095
1095 return x; 1096 return x;
1096} 1097}
1097 1098
1098/* ========== oblist implementation ========== */
1099
1100static pointer 1099static pointer
1101generate_symbol (SCHEME_P_ const char *name) 1100generate_symbol (SCHEME_P_ const char *name)
1102{ 1101{
1103 pointer x = mk_string (SCHEME_A_ name); 1102 pointer x = mk_string (SCHEME_A_ name);
1104 setimmutable (x); 1103 setimmutable (x);
1105 set_typeflag (x, T_SYMBOL | T_ATOM); 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)
… …
1393INTERFACE pointer 1394INTERFACE pointer
1394gensym (SCHEME_P) 1395gensym (SCHEME_P)
1395{ 1396{
1396 pointer x; 1397 pointer x;
1397 char name[40] = "gensym-"; 1398 char name[40] = "gensym-";
1398 xnum (name + 7, SCHEME_V->gensym_cnt); 1399 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1399 1400
1400 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;
1401} 1408}
1402 1409
1403/* make symbol or number atom from string */ 1410/* make symbol or number atom from string */
1404static pointer 1411static pointer
1405mk_atom (SCHEME_P_ char *q) 1412mk_atom (SCHEME_P_ char *q)
… …
1649 /* garbage collect */ 1656 /* garbage collect */
1650 clrmark (NIL); 1657 clrmark (NIL);
1651 SCHEME_V->fcells = 0; 1658 SCHEME_V->fcells = 0;
1652 SCHEME_V->free_cell = NIL; 1659 SCHEME_V->free_cell = NIL;
1653 1660
1654 /* free-list is kept sorted by address so as to maintain consecutive 1661 if (SCHEME_V->gc_verbose)
1655 ranges, if possible, for use with vectors. Here we scan the cells 1662 xwrstr ("freeing...");
1656 (which are also kept sorted by address) downwards to build the 1663
1657 free-list in sorted order. 1664 uint32_t total = 0;
1658 */ 1665
1666 /* Here we scan the cells to build the free-list. */
1659 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1667 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1660 { 1668 {
1661 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1669 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1670 total += SCHEME_V->cell_segsize [i];
1662 1671
1663 while (--p >= SCHEME_V->cell_seg[i]) 1672 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1664 { 1673 {
1665 if (is_mark (p)) 1674 if (is_mark (p))
1666 clrmark (p); 1675 clrmark (p);
1667 else 1676 else
1668 { 1677 {
… …
1681 } 1690 }
1682 } 1691 }
1683 1692
1684 if (SCHEME_V->gc_verbose) 1693 if (SCHEME_V->gc_verbose)
1685 { 1694 {
1686 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1695 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1687 } 1696 }
1688} 1697}
1689 1698
1690static void 1699static void
1691finalize_cell (SCHEME_P_ pointer a) 1700finalize_cell (SCHEME_P_ pointer a)
… …
2277 int c, curr_line = 0; 2286 int c, curr_line = 0;
2278 2287
2279 do 2288 do
2280 { 2289 {
2281 c = inchar (SCHEME_A); 2290 c = inchar (SCHEME_A);
2291
2282#if SHOW_ERROR_LINE 2292#if SHOW_ERROR_LINE
2283 if (c == '\n') 2293 if (ecb_expect_false (c == '\n'))
2284 curr_line++; 2294 curr_line++;
2285#endif 2295#endif
2296
2297 if (ecb_expect_false (c == EOF))
2298 return c;
2286 } 2299 }
2287 while (is_one_of (WHITESPACE, c)); 2300 while (is_one_of (WHITESPACE, c));
2288 2301
2289 /* record it */ 2302 /* record it */
2290#if SHOW_ERROR_LINE 2303#if SHOW_ERROR_LINE
2291 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2304 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2292 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2305 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2293#endif 2306#endif
2294 2307
2295 if (c != EOF)
2296 {
2297 backchar (SCHEME_A_ c); 2308 backchar (SCHEME_A_ c);
2298 return 1; 2309 return 1;
2299 }
2300 else
2301 return EOF;
2302} 2310}
2303 2311
2304/* get token */ 2312/* get token */
2305static int 2313static int
2306token (SCHEME_P) 2314token (SCHEME_P)
… …
3242 3250
3243#endif 3251#endif
3244 3252
3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3253#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3246 3254
3247#if 1 3255#if EXPERIMENT
3248static int 3256static int
3249debug (SCHEME_P_ int indent, pointer x) 3257debug (SCHEME_P_ int indent, pointer x)
3250{ 3258{
3251 int c; 3259 int c;
3252 3260
… …
3308 pointer args = SCHEME_V->args; 3316 pointer args = SCHEME_V->args;
3309 pointer x, y; 3317 pointer x, y;
3310 3318
3311 switch (op) 3319 switch (op)
3312 { 3320 {
3313#if 1 //D 3321#if EXPERIMENT //D
3314 case OP_DEBUG: 3322 case OP_DEBUG:
3315 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3323 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3316 printf ("\n"); 3324 printf ("\n");
3317 s_return (S_T); 3325 s_return (S_T);
3318#endif 3326#endif
… …
4527 pointer d = cdr (args); 4535 pointer d = cdr (args);
4528 int r; 4536 int r;
4529 4537
4530 switch (op) 4538 switch (op)
4531 { 4539 {
4532 case OP_NOT: /* not */ r = is_false (a) ; break; 4540 case OP_NOT: /* not */ r = is_false (a) ; break;
4533 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4541 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4534 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4542 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4535 case OP_NULLP: /* null? */ r = a == NIL ; break; 4543 case OP_NULLP: /* null? */ r = a == NIL ; break;
4536 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4544 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4545 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4537 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4546 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4538 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4547 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4539 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4548 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4540 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4549 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4541 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4550 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4542 4551
4543#if USE_CHAR_CLASSIFIERS 4552#if USE_CHAR_CLASSIFIERS
4544 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4553 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4545 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4554 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4546 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4555 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;

Diff Legend

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