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.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"
… …
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{
… …
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)
… …
2277 int c, curr_line = 0; 2284 int c, curr_line = 0;
2278 2285
2279 do 2286 do
2280 { 2287 {
2281 c = inchar (SCHEME_A); 2288 c = inchar (SCHEME_A);
2289
2282#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2283 if (c == '\n') 2291 if (ecb_expect_false (c == '\n'))
2284 curr_line++; 2292 curr_line++;
2285#endif 2293#endif
2294
2295 if (ecb_expect_false (c == EOF))
2296 return c;
2286 } 2297 }
2287 while (is_one_of (WHITESPACE, c)); 2298 while (is_one_of (WHITESPACE, c));
2288 2299
2289 /* record it */ 2300 /* record it */
2290#if SHOW_ERROR_LINE 2301#if SHOW_ERROR_LINE
2291 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)
2292 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;
2293#endif 2304#endif
2294 2305
2295 if (c != EOF)
2296 {
2297 backchar (SCHEME_A_ c); 2306 backchar (SCHEME_A_ c);
2298 return 1; 2307 return 1;
2299 }
2300 else
2301 return EOF;
2302} 2308}
2303 2309
2304/* get token */ 2310/* get token */
2305static int 2311static int
2306token (SCHEME_P) 2312token (SCHEME_P)
… …
3242 3248
3243#endif 3249#endif
3244 3250
3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3251#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3246 3252
3247#if 1 3253#if EXPERIMENT
3248static int 3254static int
3249debug (SCHEME_P_ int indent, pointer x) 3255debug (SCHEME_P_ int indent, pointer x)
3250{ 3256{
3251 int c; 3257 int c;
3252 3258
… …
3308 pointer args = SCHEME_V->args; 3314 pointer args = SCHEME_V->args;
3309 pointer x, y; 3315 pointer x, y;
3310 3316
3311 switch (op) 3317 switch (op)
3312 { 3318 {
3313#if 1 //D 3319#if EXPERIMENT //D
3314 case OP_DEBUG: 3320 case OP_DEBUG:
3315 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3321 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3316 printf ("\n"); 3322 printf ("\n");
3317 s_return (S_T); 3323 s_return (S_T);
3318#endif 3324#endif
… …
4527 pointer d = cdr (args); 4533 pointer d = cdr (args);
4528 int r; 4534 int r;
4529 4535
4530 switch (op) 4536 switch (op)
4531 { 4537 {
4532 case OP_NOT: /* not */ r = is_false (a) ; break; 4538 case OP_NOT: /* not */ r = is_false (a) ; break;
4533 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;
4534 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4540 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4535 case OP_NULLP: /* null? */ r = a == NIL ; break; 4541 case OP_NULLP: /* null? */ r = a == NIL ; break;
4536 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;
4537 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4544 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4538 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4545 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4539 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4546 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4540 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 */
4541 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4548 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4542 4549
4543#if USE_CHAR_CLASSIFIERS 4550#if USE_CHAR_CLASSIFIERS
4544 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4551 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4545 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4552 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4546 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4553 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;

Diff Legend

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