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.47 by root, Mon Nov 30 09:25:19 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#error plists are broken because symbols are no longer pairs
419#define symprop(p) cdr(p)
416SCHEME_EXPORT int 420SCHEME_EXPORT int
417hasprop (pointer p) 421hasprop (pointer p)
418{ 422{
419 return typeflag (p) & T_SYMBOL; 423 return typeflag (p) & T_SYMBOL;
420} 424}
421
422# define symprop(p) cdr(p)
423#endif 425#endif
424 426
425INTERFACE int 427INTERFACE int
426is_syntax (pointer p) 428is_syntax (pointer p)
427{ 429{
… …
968 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 970 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
969 return S_SINK; 971 return S_SINK;
970 972
971 if (SCHEME_V->free_cell == NIL) 973 if (SCHEME_V->free_cell == NIL)
972 { 974 {
973 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 975 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
974 976
975 gc (SCHEME_A_ a, b); 977 gc (SCHEME_A_ a, b);
976 978
977 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
978 { 980 {
… …
1029} 1031}
1030 1032
1031static pointer 1033static pointer
1032get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1034get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1033{ 1035{
1034 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1036 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1035 pointer *e = malloc (len * sizeof (pointer)); 1037 pointer *e = malloc (len * sizeof (pointer));
1036 1038
1037 if (!e && USE_ERROR_CHECKING) 1039 if (!e && USE_ERROR_CHECKING)
1038 return S_SINK; 1040 return S_SINK;
1039 1041
… …
1093 set_cdr (x, b); 1095 set_cdr (x, b);
1094 1096
1095 return x; 1097 return x;
1096} 1098}
1097 1099
1098/* ========== oblist implementation ========== */
1099
1100static pointer 1100static pointer
1101generate_symbol (SCHEME_P_ const char *name) 1101generate_symbol (SCHEME_P_ const char *name)
1102{ 1102{
1103 pointer x = mk_string (SCHEME_A_ name); 1103 pointer x = mk_string (SCHEME_A_ name);
1104 setimmutable (x); 1104 setimmutable (x);
1105 set_typeflag (x, T_SYMBOL | T_ATOM); 1105 set_typeflag (x, T_SYMBOL | T_ATOM);
1106 return x; 1106 return x;
1107} 1107}
1108
1109/* ========== oblist implementation ========== */
1108 1110
1109#ifndef USE_OBJECT_LIST 1111#ifndef USE_OBJECT_LIST
1110 1112
1111static int 1113static int
1112hash_fn (const char *key, int table_size) 1114hash_fn (const char *key, int table_size)
… …
1393INTERFACE pointer 1395INTERFACE pointer
1394gensym (SCHEME_P) 1396gensym (SCHEME_P)
1395{ 1397{
1396 pointer x; 1398 pointer x;
1397 char name[40] = "gensym-"; 1399 char name[40] = "gensym-";
1398 xnum (name + 7, SCHEME_V->gensym_cnt); 1400 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1399 1401
1400 return generate_symbol (SCHEME_A_ name); 1402 return generate_symbol (SCHEME_A_ name);
1403}
1404
1405static int
1406is_gensym (SCHEME_P_ pointer x)
1407{
1408 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1401} 1409}
1402 1410
1403/* make symbol or number atom from string */ 1411/* make symbol or number atom from string */
1404static pointer 1412static pointer
1405mk_atom (SCHEME_P_ char *q) 1413mk_atom (SCHEME_P_ char *q)
… …
1649 /* garbage collect */ 1657 /* garbage collect */
1650 clrmark (NIL); 1658 clrmark (NIL);
1651 SCHEME_V->fcells = 0; 1659 SCHEME_V->fcells = 0;
1652 SCHEME_V->free_cell = NIL; 1660 SCHEME_V->free_cell = NIL;
1653 1661
1654 /* free-list is kept sorted by address so as to maintain consecutive 1662 if (SCHEME_V->gc_verbose)
1655 ranges, if possible, for use with vectors. Here we scan the cells 1663 xwrstr ("freeing...");
1656 (which are also kept sorted by address) downwards to build the 1664
1657 free-list in sorted order. 1665 uint32_t total = 0;
1658 */ 1666
1667 /* Here we scan the cells to build the free-list. */
1659 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1668 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1660 { 1669 {
1661 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1670 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1671 total += SCHEME_V->cell_segsize [i];
1662 1672
1663 while (--p >= SCHEME_V->cell_seg[i]) 1673 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1664 { 1674 {
1665 if (is_mark (p)) 1675 if (is_mark (p))
1666 clrmark (p); 1676 clrmark (p);
1667 else 1677 else
1668 { 1678 {
… …
1681 } 1691 }
1682 } 1692 }
1683 1693
1684 if (SCHEME_V->gc_verbose) 1694 if (SCHEME_V->gc_verbose)
1685 { 1695 {
1686 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1696 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1687 } 1697 }
1688} 1698}
1689 1699
1690static void 1700static void
1691finalize_cell (SCHEME_P_ pointer a) 1701finalize_cell (SCHEME_P_ pointer a)
… …
2277 int c, curr_line = 0; 2287 int c, curr_line = 0;
2278 2288
2279 do 2289 do
2280 { 2290 {
2281 c = inchar (SCHEME_A); 2291 c = inchar (SCHEME_A);
2292
2282#if SHOW_ERROR_LINE 2293#if SHOW_ERROR_LINE
2283 if (c == '\n') 2294 if (ecb_expect_false (c == '\n'))
2284 curr_line++; 2295 curr_line++;
2285#endif 2296#endif
2297
2298 if (ecb_expect_false (c == EOF))
2299 return c;
2286 } 2300 }
2287 while (is_one_of (WHITESPACE, c)); 2301 while (is_one_of (WHITESPACE, c));
2288 2302
2289 /* record it */ 2303 /* record it */
2290#if SHOW_ERROR_LINE 2304#if SHOW_ERROR_LINE
2291 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2305 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; 2306 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2293#endif 2307#endif
2294 2308
2295 if (c != EOF)
2296 {
2297 backchar (SCHEME_A_ c); 2309 backchar (SCHEME_A_ c);
2298 return 1; 2310 return 1;
2299 }
2300 else
2301 return EOF;
2302} 2311}
2303 2312
2304/* get token */ 2313/* get token */
2305static int 2314static int
2306token (SCHEME_P) 2315token (SCHEME_P)
… …
3242 3251
3243#endif 3252#endif
3244 3253
3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3254#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3246 3255
3247#if 1 3256#if EXPERIMENT
3248static int 3257static int
3249debug (SCHEME_P_ int indent, pointer x) 3258debug (SCHEME_P_ int indent, pointer x)
3250{ 3259{
3251 int c; 3260 int c;
3252 3261
… …
3308 pointer args = SCHEME_V->args; 3317 pointer args = SCHEME_V->args;
3309 pointer x, y; 3318 pointer x, y;
3310 3319
3311 switch (op) 3320 switch (op)
3312 { 3321 {
3313#if 1 //D 3322#if EXPERIMENT //D
3314 case OP_DEBUG: 3323 case OP_DEBUG:
3315 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3324 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3316 printf ("\n"); 3325 printf ("\n");
3317 s_return (S_T); 3326 s_return (S_T);
3318#endif 3327#endif
… …
4191 else 4200 else
4192 Error_0 ("modulo: division by zero"); 4201 Error_0 ("modulo: division by zero");
4193 4202
4194 s_return (mk_number (SCHEME_A_ v)); 4203 s_return (mk_number (SCHEME_A_ v));
4195 4204
4196 case OP_CAR: /* car */ 4205 /* the compiler will optimize this mess... */
4197 s_return (caar (args)); 4206 case OP_CAR: op_car: s_return (car (x));
4198 4207 case OP_CDR: op_cdr: s_return (cdr (x));
4199 case OP_CDR: /* cdr */ 4208 case OP_CAAR: op_caar: x = car (x); goto op_car;
4200 s_return (cdar (args)); 4209 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4210 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4211 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4212 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4213 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4214 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4215 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4216 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4217 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4218 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4219 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4220 case OP_CAAAAR: x = car (x); goto op_caaar;
4221 case OP_CAAADR: x = cdr (x); goto op_caaar;
4222 case OP_CAADAR: x = car (x); goto op_caadr;
4223 case OP_CAADDR: x = cdr (x); goto op_caadr;
4224 case OP_CADAAR: x = car (x); goto op_cadar;
4225 case OP_CADADR: x = cdr (x); goto op_cadar;
4226 case OP_CADDAR: x = car (x); goto op_caddr;
4227 case OP_CADDDR: x = cdr (x); goto op_caddr;
4228 case OP_CDAAAR: x = car (x); goto op_cdaar;
4229 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4230 case OP_CDADAR: x = car (x); goto op_cdadr;
4231 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4232 case OP_CDDAAR: x = car (x); goto op_cddar;
4233 case OP_CDDADR: x = cdr (x); goto op_cddar;
4234 case OP_CDDDAR: x = car (x); goto op_cdddr;
4235 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4201 4236
4202 case OP_CONS: /* cons */ 4237 case OP_CONS: /* cons */
4203 set_cdr (args, cadr (args)); 4238 set_cdr (args, cadr (args));
4204 s_return (args); 4239 s_return (args);
4205 4240
… …
4527 pointer d = cdr (args); 4562 pointer d = cdr (args);
4528 int r; 4563 int r;
4529 4564
4530 switch (op) 4565 switch (op)
4531 { 4566 {
4532 case OP_NOT: /* not */ r = is_false (a) ; break; 4567 case OP_NOT: /* not */ r = is_false (a) ; break;
4533 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4568 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4534 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4569 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4535 case OP_NULLP: /* null? */ r = a == NIL ; break; 4570 case OP_NULLP: /* null? */ r = a == NIL ; break;
4536 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4571 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4572 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4537 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4573 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4538 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4574 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4539 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4575 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4540 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4576 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4541 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4577 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4542 4578
4543#if USE_CHAR_CLASSIFIERS 4579#if USE_CHAR_CLASSIFIERS
4544 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4580 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4545 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4581 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4546 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4582 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;

Diff Legend

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