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.32 by root, Sat Nov 28 10:56:45 2015 UTC vs.
Revision 1.35 by root, Sun Nov 29 00:02:21 2015 UTC

… …
34 34
35#include <sys/types.h> 35#include <sys/types.h>
36#include <sys/stat.h> 36#include <sys/stat.h>
37#include <fcntl.h> 37#include <fcntl.h>
38 38
39#if !USE_ERROR_CHECKING
40# define NDEBUG
41#endif
42
43#include <assert.h>
44#include <stdlib.h>
39#include <string.h> 45#include <string.h>
40#include <stdlib.h>
41 46
42#include <limits.h> 47#include <limits.h>
43#include <inttypes.h> 48#include <inttypes.h>
44#include <float.h> 49#include <float.h>
45//#include <ctype.h> 50//#include <ctype.h>
51
52#if '1' != '0' + 1 \
53 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
54 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
55 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
56 || 'f' != 'a' + 5
57# error "execution character set digits not consecutive"
58#endif
46 59
47enum { 60enum {
48 TOK_EOF, 61 TOK_EOF,
49 TOK_LPAREN, 62 TOK_LPAREN,
50 TOK_RPAREN, 63 TOK_RPAREN,
51 TOK_DOT, 64 TOK_DOT,
52 TOK_ATOM, 65 TOK_ATOM,
66 TOK_DOTATOM, /* atom name starting with '.' */
67 TOK_STRATOM, /* atom name enclosed in | */
53 TOK_QUOTE, 68 TOK_QUOTE,
54 TOK_DQUOTE, 69 TOK_DQUOTE,
55 TOK_BQUOTE, 70 TOK_BQUOTE,
56 TOK_COMMA, 71 TOK_COMMA,
57 TOK_ATMARK, 72 TOK_ATMARK,
… …
651#endif 666#endif
652 667
653static int file_push (SCHEME_P_ const char *fname); 668static int file_push (SCHEME_P_ const char *fname);
654static void file_pop (SCHEME_P); 669static void file_pop (SCHEME_P);
655static int file_interactive (SCHEME_P); 670static int file_interactive (SCHEME_P);
656ecb_inline int is_one_of (char *s, int c); 671ecb_inline int is_one_of (const char *s, int c);
657static int alloc_cellseg (SCHEME_P_ int n); 672static int alloc_cellseg (SCHEME_P_ int n);
658ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 673ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
659static void finalize_cell (SCHEME_P_ pointer a); 674static void finalize_cell (SCHEME_P_ pointer a);
660static int count_consecutive_cells (pointer x, int needed); 675static int count_consecutive_cells (pointer x, int needed);
661static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 676static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
… …
678static void mark (pointer a); 693static void mark (pointer a);
679static void gc (SCHEME_P_ pointer a, pointer b); 694static void gc (SCHEME_P_ pointer a, pointer b);
680static int basic_inchar (port *pt); 695static int basic_inchar (port *pt);
681static int inchar (SCHEME_P); 696static int inchar (SCHEME_P);
682static void backchar (SCHEME_P_ int c); 697static void backchar (SCHEME_P_ int c);
683static char *readstr_upto (SCHEME_P_ char *delim); 698static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
684static pointer readstrexp (SCHEME_P); 699static pointer readstrexp (SCHEME_P_ char delim);
685ecb_inline int skipspace (SCHEME_P); 700ecb_inline int skipspace (SCHEME_P);
686static int token (SCHEME_P); 701static int token (SCHEME_P);
687static void printslashstring (SCHEME_P_ char *s, int len); 702static void printslashstring (SCHEME_P_ char *s, int len);
688static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 703static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
689static void printatom (SCHEME_P_ pointer l, int f); 704static void printatom (SCHEME_P_ pointer l, int f);
… …
1079 return x; 1094 return x;
1080} 1095}
1081 1096
1082/* ========== oblist implementation ========== */ 1097/* ========== oblist implementation ========== */
1083 1098
1099static pointer
1100generate_symbol (SCHEME_P_ const char *name)
1101{
1102 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x);
1104 x = immutable_cons (x, NIL);
1105 set_typeflag (x, T_SYMBOL);
1106 return x;
1107}
1108
1084#ifndef USE_OBJECT_LIST 1109#ifndef USE_OBJECT_LIST
1085 1110
1111static int
1086static int hash_fn (const char *key, int table_size); 1112hash_fn (const char *key, int table_size)
1113{
1114 const unsigned char *p = key;
1115 uint32_t hash = 2166136261;
1116
1117 while (*p)
1118 hash = (hash ^ *p++) * 16777619;
1119
1120 return hash % table_size;
1121}
1087 1122
1088static pointer 1123static pointer
1089oblist_initial_value (SCHEME_P) 1124oblist_initial_value (SCHEME_P)
1090{ 1125{
1091 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1126 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
… …
1093 1128
1094/* returns the new symbol */ 1129/* returns the new symbol */
1095static pointer 1130static pointer
1096oblist_add_by_name (SCHEME_P_ const char *name) 1131oblist_add_by_name (SCHEME_P_ const char *name)
1097{ 1132{
1098 int location; 1133 pointer x = generate_symbol (SCHEME_A_ name);
1099
1100 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1101 set_typeflag (x, T_SYMBOL);
1102 setimmutable (car (x));
1103
1104 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1134 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1105 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1135 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1106 return x; 1136 return x;
1107} 1137}
1108 1138
1109ecb_inline pointer 1139ecb_inline pointer
… …
1271 SCHEME_V->no_memory = 1; 1301 SCHEME_V->no_memory = 1;
1272 return SCHEME_V->strbuff; 1302 return SCHEME_V->strbuff;
1273 } 1303 }
1274 1304
1275 if (str) 1305 if (str)
1276 { 1306 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1277 int l = strlen (str);
1278
1279 if (l > len_str)
1280 l = len_str;
1281
1282 memcpy (q, str, l);
1283 q[l] = 0;
1284 }
1285 else 1307 else
1286 {
1287 memset (q, fill, len_str); 1308 memset (q, fill, len_str);
1309
1288 q[len_str] = 0; 1310 q[len_str] = 0;
1289 }
1290 1311
1291 return q; 1312 return q;
1292} 1313}
1293 1314
1294INTERFACE pointer 1315INTERFACE pointer
… …
1308 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1329 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1309 1330
1310 set_typeflag (x, T_STRING | T_ATOM); 1331 set_typeflag (x, T_STRING | T_ATOM);
1311 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1332 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1312 strlength (x) = len; 1333 strlength (x) = len;
1334
1313 return x; 1335 return x;
1314} 1336}
1315 1337
1316INTERFACE pointer 1338INTERFACE pointer
1317mk_string (SCHEME_P_ const char *str) 1339mk_string (SCHEME_P_ const char *str)
… …
1361 1383
1362INTERFACE pointer 1384INTERFACE pointer
1363gensym (SCHEME_P) 1385gensym (SCHEME_P)
1364{ 1386{
1365 pointer x; 1387 pointer x;
1366
1367 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1368 {
1369 char name[40] = "gensym-"; 1388 char name[40] = "gensym-";
1370 xnum (name + 7, SCHEME_V->gensym_cnt); 1389 xnum (name + 7, SCHEME_V->gensym_cnt);
1371 1390
1372 /* first check oblist */ 1391 return generate_symbol (SCHEME_A_ name);
1373 x = oblist_find_by_name (SCHEME_A_ name);
1374
1375 if (x == NIL)
1376 {
1377 x = oblist_add_by_name (SCHEME_A_ name);
1378 return x;
1379 }
1380 }
1381
1382 return NIL;
1383} 1392}
1384 1393
1385/* make symbol or number atom from string */ 1394/* make symbol or number atom from string */
1386static pointer 1395static pointer
1387mk_atom (SCHEME_P_ char *q) 1396mk_atom (SCHEME_P_ char *q)
… …
2103#endif 2112#endif
2104} 2113}
2105 2114
2106/* read characters up to delimiter, but cater to character constants */ 2115/* read characters up to delimiter, but cater to character constants */
2107static char * 2116static char *
2108readstr_upto (SCHEME_P_ char *delim) 2117readstr_upto (SCHEME_P_ int skip, const char *delim)
2109{ 2118{
2110 char *p = SCHEME_V->strbuff; 2119 char *p = SCHEME_V->strbuff + skip;
2111 2120
2112 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2121 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2113 2122
2114 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2123 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2115 *p = 0; 2124 *p = 0;
… …
2122 return SCHEME_V->strbuff; 2131 return SCHEME_V->strbuff;
2123} 2132}
2124 2133
2125/* read string expression "xxx...xxx" */ 2134/* read string expression "xxx...xxx" */
2126static pointer 2135static pointer
2127readstrexp (SCHEME_P) 2136readstrexp (SCHEME_P_ char delim)
2128{ 2137{
2129 char *p = SCHEME_V->strbuff; 2138 char *p = SCHEME_V->strbuff;
2130 int c; 2139 int c;
2131 int c1 = 0; 2140 int c1 = 0;
2132 enum
2133 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2141 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2134 2142
2135 for (;;) 2143 for (;;)
2136 { 2144 {
2137 c = inchar (SCHEME_A); 2145 c = inchar (SCHEME_A);
2138 2146
… …
2140 return S_F; 2148 return S_F;
2141 2149
2142 switch (state) 2150 switch (state)
2143 { 2151 {
2144 case st_ok: 2152 case st_ok:
2145 switch (c) 2153 if (ecb_expect_false (c == delim))
2146 {
2147 case '\\':
2148 state = st_bsl;
2149 break;
2150
2151 case '"':
2152 *p = 0;
2153 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2154 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2154 2155
2155 default: 2156 if (ecb_expect_false (c == '\\'))
2157 state = st_bsl;
2158 else
2156 *p++ = c; 2159 *p++ = c;
2157 break;
2158 }
2159 2160
2160 break; 2161 break;
2161 2162
2162 case st_bsl: 2163 case st_bsl:
2163 switch (c) 2164 switch (c)
… …
2193 case 'r': 2194 case 'r':
2194 *p++ = '\r'; 2195 *p++ = '\r';
2195 state = st_ok; 2196 state = st_ok;
2196 break; 2197 break;
2197 2198
2198 case '"':
2199 *p++ = '"';
2200 state = st_ok;
2201 break;
2202
2203 default: 2199 default:
2204 *p++ = c; 2200 *p++ = c;
2205 state = st_ok; 2201 state = st_ok;
2206 break; 2202 break;
2207 } 2203 }
2208 2204
2209 break; 2205 break;
2210 2206
2211 case st_x1: 2207 case st_x1:
2212 case st_x2: 2208 case st_x2:
2213 c = toupper (c); 2209 c = tolower (c);
2214 2210
2215 if (c >= '0' && c <= 'F') 2211 if (c >= '0' && c <= '9')
2216 {
2217 if (c <= '9')
2218 c1 = (c1 << 4) + c - '0'; 2212 c1 = (c1 << 4) + c - '0';
2219 else 2213 else if (c >= 'a' && c <= 'f')
2220 c1 = (c1 << 4) + c - 'A' + 10; 2214 c1 = (c1 << 4) + c - 'a' + 10;
2221
2222 if (state == st_x1)
2223 state = st_x2;
2224 else
2225 {
2226 *p++ = c1;
2227 state = st_ok;
2228 }
2229 }
2230 else 2215 else
2231 return S_F; 2216 return S_F;
2217
2218 if (state == st_x1)
2219 state = st_x2;
2220 else
2221 {
2222 *p++ = c1;
2223 state = st_ok;
2224 }
2232 2225
2233 break; 2226 break;
2234 2227
2235 case st_oct1: 2228 case st_oct1:
2236 case st_oct2: 2229 case st_oct2:
… …
2240 backchar (SCHEME_A_ c); 2233 backchar (SCHEME_A_ c);
2241 state = st_ok; 2234 state = st_ok;
2242 } 2235 }
2243 else 2236 else
2244 { 2237 {
2245 if (state == st_oct2 && c1 >= 32) 2238 if (state == st_oct2 && c1 >= ' ')
2246 return S_F; 2239 return S_F;
2247 2240
2248 c1 = (c1 << 3) + (c - '0'); 2241 c1 = (c1 << 3) + (c - '0');
2249 2242
2250 if (state == st_oct1) 2243 if (state == st_oct1)
… …
2255 state = st_ok; 2248 state = st_ok;
2256 } 2249 }
2257 } 2250 }
2258 2251
2259 break; 2252 break;
2260
2261 } 2253 }
2262 } 2254 }
2263} 2255}
2264 2256
2265/* check c is in chars */ 2257/* check c is in chars */
2266ecb_inline int 2258ecb_inline int
2267is_one_of (char *s, int c) 2259is_one_of (const char *s, int c)
2268{ 2260{
2269 if (c == EOF) 2261 if (c == EOF)
2270 return 1; 2262 return 1;
2271 2263
2272 return !!strchr (s, c); 2264 return !!strchr (s, c);
… …
2328 2320
2329 if (is_one_of (" \n\t", c)) 2321 if (is_one_of (" \n\t", c))
2330 return TOK_DOT; 2322 return TOK_DOT;
2331 else 2323 else
2332 { 2324 {
2333 //TODO: ungetc twice in a row is not supported in C
2334 backchar (SCHEME_A_ c); 2325 backchar (SCHEME_A_ c);
2335 backchar (SCHEME_A_ '.');
2336 return TOK_ATOM; 2326 return TOK_DOTATOM;
2337 } 2327 }
2328
2329 case '|':
2330 return TOK_STRATOM;
2338 2331
2339 case '\'': 2332 case '\'':
2340 return TOK_QUOTE; 2333 return TOK_QUOTE;
2341 2334
2342 case ';': 2335 case ';':
… …
2811#define is_true(p) ((p) != S_F) 2804#define is_true(p) ((p) != S_F)
2812#define is_false(p) ((p) == S_F) 2805#define is_false(p) ((p) == S_F)
2813 2806
2814/* ========== Environment implementation ========== */ 2807/* ========== Environment implementation ========== */
2815 2808
2816#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2817
2818static int
2819hash_fn (const char *key, int table_size)
2820{
2821 const unsigned char *p = key;
2822 uint32_t hash = 2166136261;
2823
2824 while (*p)
2825 hash = (hash ^ *p++) * 16777619;
2826
2827 return hash % table_size;
2828}
2829#endif
2830
2831#ifndef USE_ALIST_ENV 2809#ifndef USE_ALIST_ENV
2832 2810
2833/* 2811/*
2834 * In this implementation, each frame of the environment may be 2812 * In this implementation, each frame of the environment may be
2835 * a hash table: a vector of alists hashed by variable name. 2813 * a hash table: a vector of alists hashed by variable name.
… …
2857sym_hash (pointer sym, uint32_t size) 2835sym_hash (pointer sym, uint32_t size)
2858{ 2836{
2859 uintptr_t ptr = (uintptr_t)sym; 2837 uintptr_t ptr = (uintptr_t)sym;
2860 2838
2861#if 0 2839#if 0
2862 /* tqable size is prime, so why mix */ 2840 /* table size is prime, so why mix */
2863 ptr += ptr >> 32; 2841 ptr += ptr >> 32;
2864 ptr += ptr >> 16; 2842 ptr += ptr >> 16;
2865 ptr += ptr >> 8; 2843 ptr += ptr >> 8;
2866#endif 2844#endif
2867 2845
… …
4964 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 4942 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4965 SCHEME_V->tok = token (SCHEME_A); 4943 SCHEME_V->tok = token (SCHEME_A);
4966 s_goto (OP_RDSEXPR); 4944 s_goto (OP_RDSEXPR);
4967 4945
4968 case TOK_ATOM: 4946 case TOK_ATOM:
4969 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 4947 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
4948
4949 case TOK_DOTATOM:
4950 SCHEME_V->strbuff[0] = '.';
4951 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
4970 4952
4971 case TOK_DQUOTE: 4953 case TOK_DQUOTE:
4972 x = readstrexp (SCHEME_A); 4954 x = readstrexp (SCHEME_A_ '"');
4973 4955
4974 if (x == S_F) 4956 if (x == S_F)
4975 Error_0 ("Error reading string"); 4957 Error_0 ("Error reading string");
4976 4958
4977 setimmutable (x); 4959 setimmutable (x);
… …
4989 s_goto (OP_EVAL); 4971 s_goto (OP_EVAL);
4990 } 4972 }
4991 } 4973 }
4992 4974
4993 case TOK_SHARP_CONST: 4975 case TOK_SHARP_CONST:
4994 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 4976 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4995 Error_0 ("undefined sharp expression"); 4977 Error_0 ("undefined sharp expression");
4996 else 4978 else
4997 s_return (x); 4979 s_return (x);
4998 4980
4999 default: 4981 default:

Diff Legend

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