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.29 by root, Sat Nov 28 10:31:06 2015 UTC vs.
Revision 1.38 by root, Sun Nov 29 13:47:15 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,
… …
391} 406}
392 407
393INTERFACE char * 408INTERFACE char *
394symname (pointer p) 409symname (pointer p)
395{ 410{
396 return strvalue (car (p)); 411 return strvalue (p);
397} 412}
398 413
399#if USE_PLIST 414#if USE_PLIST
400SCHEME_EXPORT int 415SCHEME_EXPORT int
401hasprop (pointer p) 416hasprop (pointer p)
… …
425} 440}
426 441
427INTERFACE char * 442INTERFACE char *
428syntaxname (pointer p) 443syntaxname (pointer p)
429{ 444{
430 return strvalue (car (p)); 445 return strvalue (p);
431} 446}
432 447
433#define procnum(p) ivalue_unchecked (p) 448#define procnum(p) ivalue_unchecked (p)
434static const char *procname (pointer x); 449static const char *procname (pointer x);
435 450
… …
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 set_typeflag (x, T_SYMBOL | T_ATOM);
1105 return x;
1106}
1107
1084#ifndef USE_OBJECT_LIST 1108#ifndef USE_OBJECT_LIST
1085 1109
1110static int
1086static int hash_fn (const char *key, int table_size); 1111hash_fn (const char *key, int table_size)
1112{
1113 const unsigned char *p = key;
1114 uint32_t hash = 2166136261;
1115
1116 while (*p)
1117 hash = (hash ^ *p++) * 16777619;
1118
1119 return hash % table_size;
1120}
1087 1121
1088static pointer 1122static pointer
1089oblist_initial_value (SCHEME_P) 1123oblist_initial_value (SCHEME_P)
1090{ 1124{
1091 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1125 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
… …
1093 1127
1094/* returns the new symbol */ 1128/* returns the new symbol */
1095static pointer 1129static pointer
1096oblist_add_by_name (SCHEME_P_ const char *name) 1130oblist_add_by_name (SCHEME_P_ const char *name)
1097{ 1131{
1098 int location; 1132 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)); 1133 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))); 1134 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1106 return x; 1135 return x;
1107} 1136}
1108 1137
1109ecb_inline pointer 1138ecb_inline pointer
… …
1169 1198
1170/* returns the new symbol */ 1199/* returns the new symbol */
1171static pointer 1200static pointer
1172oblist_add_by_name (SCHEME_P_ const char *name) 1201oblist_add_by_name (SCHEME_P_ const char *name)
1173{ 1202{
1174 pointer x; 1203 pointer x = mk_string (SCHEME_A_ name);
1175
1176 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1177 set_typeflag (x, T_SYMBOL); 1204 set_typeflag (x, T_SYMBOL);
1178 setimmutable (car (x)); 1205 setimmutable (x);
1179 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1206 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1180 return x; 1207 return x;
1181} 1208}
1182 1209
1183static pointer 1210static pointer
… …
1273 SCHEME_V->no_memory = 1; 1300 SCHEME_V->no_memory = 1;
1274 return SCHEME_V->strbuff; 1301 return SCHEME_V->strbuff;
1275 } 1302 }
1276 1303
1277 if (str) 1304 if (str)
1278 { 1305 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1279 int l = strlen (str);
1280
1281 if (l > len_str)
1282 l = len_str;
1283
1284 memcpy (q, str, l);
1285 q[l] = 0;
1286 }
1287 else 1306 else
1288 {
1289 memset (q, fill, len_str); 1307 memset (q, fill, len_str);
1308
1290 q[len_str] = 0; 1309 q[len_str] = 0;
1291 }
1292 1310
1293 return q; 1311 return q;
1294} 1312}
1295 1313
1296INTERFACE pointer 1314INTERFACE pointer
… …
1310 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1328 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1311 1329
1312 set_typeflag (x, T_STRING | T_ATOM); 1330 set_typeflag (x, T_STRING | T_ATOM);
1313 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1331 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1314 strlength (x) = len; 1332 strlength (x) = len;
1333
1315 return x; 1334 return x;
1316} 1335}
1317 1336
1318INTERFACE pointer 1337INTERFACE pointer
1319mk_string (SCHEME_P_ const char *str) 1338mk_string (SCHEME_P_ const char *str)
… …
1332{ 1351{
1333 int i; 1352 int i;
1334 1353
1335 for (i = start; i < veclength (vec); i++) 1354 for (i = start; i < veclength (vec); i++)
1336 vecvalue (vec)[i] = obj; 1355 vecvalue (vec)[i] = obj;
1356}
1357
1358INTERFACE void
1359vector_resize (pointer vec, uint32_t newsize, pointer fill)
1360{
1361 uint32_t oldsize = veclength (vec);
1362 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1363 veclength (vec) = newsize;
1364 fill_vector (vec, oldsize, fill);
1337} 1365}
1338 1366
1339INTERFACE pointer 1367INTERFACE pointer
1340vector_get (pointer vec, uint32_t ielem) 1368vector_get (pointer vec, uint32_t ielem)
1341{ 1369{
… …
1363 1391
1364INTERFACE pointer 1392INTERFACE pointer
1365gensym (SCHEME_P) 1393gensym (SCHEME_P)
1366{ 1394{
1367 pointer x; 1395 pointer x;
1368
1369 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1370 {
1371 char name[40] = "gensym-"; 1396 char name[40] = "gensym-";
1372 xnum (name + 7, SCHEME_V->gensym_cnt); 1397 xnum (name + 7, SCHEME_V->gensym_cnt);
1373 1398
1374 /* first check oblist */ 1399 return generate_symbol (SCHEME_A_ name);
1375 x = oblist_find_by_name (SCHEME_A_ name);
1376
1377 if (x == NIL)
1378 {
1379 x = oblist_add_by_name (SCHEME_A_ name);
1380 return x;
1381 }
1382 }
1383
1384 return NIL;
1385} 1400}
1386 1401
1387/* make symbol or number atom from string */ 1402/* make symbol or number atom from string */
1388static pointer 1403static pointer
1389mk_atom (SCHEME_P_ char *q) 1404mk_atom (SCHEME_P_ char *q)
… …
2105#endif 2120#endif
2106} 2121}
2107 2122
2108/* read characters up to delimiter, but cater to character constants */ 2123/* read characters up to delimiter, but cater to character constants */
2109static char * 2124static char *
2110readstr_upto (SCHEME_P_ char *delim) 2125readstr_upto (SCHEME_P_ int skip, const char *delim)
2111{ 2126{
2112 char *p = SCHEME_V->strbuff; 2127 char *p = SCHEME_V->strbuff + skip;
2113 2128
2114 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2129 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2115 2130
2116 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2131 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2117 *p = 0; 2132 *p = 0;
… …
2124 return SCHEME_V->strbuff; 2139 return SCHEME_V->strbuff;
2125} 2140}
2126 2141
2127/* read string expression "xxx...xxx" */ 2142/* read string expression "xxx...xxx" */
2128static pointer 2143static pointer
2129readstrexp (SCHEME_P) 2144readstrexp (SCHEME_P_ char delim)
2130{ 2145{
2131 char *p = SCHEME_V->strbuff; 2146 char *p = SCHEME_V->strbuff;
2132 int c; 2147 int c;
2133 int c1 = 0; 2148 int c1 = 0;
2134 enum
2135 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2149 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2136 2150
2137 for (;;) 2151 for (;;)
2138 { 2152 {
2139 c = inchar (SCHEME_A); 2153 c = inchar (SCHEME_A);
2140 2154
… …
2142 return S_F; 2156 return S_F;
2143 2157
2144 switch (state) 2158 switch (state)
2145 { 2159 {
2146 case st_ok: 2160 case st_ok:
2147 switch (c) 2161 if (ecb_expect_false (c == delim))
2148 {
2149 case '\\':
2150 state = st_bsl;
2151 break;
2152
2153 case '"':
2154 *p = 0;
2155 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2162 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2156 2163
2157 default: 2164 if (ecb_expect_false (c == '\\'))
2165 state = st_bsl;
2166 else
2158 *p++ = c; 2167 *p++ = c;
2159 break;
2160 }
2161 2168
2162 break; 2169 break;
2163 2170
2164 case st_bsl: 2171 case st_bsl:
2165 switch (c) 2172 switch (c)
… …
2195 case 'r': 2202 case 'r':
2196 *p++ = '\r'; 2203 *p++ = '\r';
2197 state = st_ok; 2204 state = st_ok;
2198 break; 2205 break;
2199 2206
2200 case '"':
2201 *p++ = '"';
2202 state = st_ok;
2203 break;
2204
2205 default: 2207 default:
2206 *p++ = c; 2208 *p++ = c;
2207 state = st_ok; 2209 state = st_ok;
2208 break; 2210 break;
2209 } 2211 }
2210 2212
2211 break; 2213 break;
2212 2214
2213 case st_x1: 2215 case st_x1:
2214 case st_x2: 2216 case st_x2:
2215 c = toupper (c); 2217 c = tolower (c);
2216 2218
2217 if (c >= '0' && c <= 'F') 2219 if (c >= '0' && c <= '9')
2218 {
2219 if (c <= '9')
2220 c1 = (c1 << 4) + c - '0'; 2220 c1 = (c1 << 4) + c - '0';
2221 else 2221 else if (c >= 'a' && c <= 'f')
2222 c1 = (c1 << 4) + c - 'A' + 10; 2222 c1 = (c1 << 4) + c - 'a' + 10;
2223
2224 if (state == st_x1)
2225 state = st_x2;
2226 else
2227 {
2228 *p++ = c1;
2229 state = st_ok;
2230 }
2231 }
2232 else 2223 else
2233 return S_F; 2224 return S_F;
2225
2226 if (state == st_x1)
2227 state = st_x2;
2228 else
2229 {
2230 *p++ = c1;
2231 state = st_ok;
2232 }
2234 2233
2235 break; 2234 break;
2236 2235
2237 case st_oct1: 2236 case st_oct1:
2238 case st_oct2: 2237 case st_oct2:
… …
2242 backchar (SCHEME_A_ c); 2241 backchar (SCHEME_A_ c);
2243 state = st_ok; 2242 state = st_ok;
2244 } 2243 }
2245 else 2244 else
2246 { 2245 {
2247 if (state == st_oct2 && c1 >= 32) 2246 if (state == st_oct2 && c1 >= ' ')
2248 return S_F; 2247 return S_F;
2249 2248
2250 c1 = (c1 << 3) + (c - '0'); 2249 c1 = (c1 << 3) + (c - '0');
2251 2250
2252 if (state == st_oct1) 2251 if (state == st_oct1)
… …
2257 state = st_ok; 2256 state = st_ok;
2258 } 2257 }
2259 } 2258 }
2260 2259
2261 break; 2260 break;
2262
2263 } 2261 }
2264 } 2262 }
2265} 2263}
2266 2264
2267/* check c is in chars */ 2265/* check c is in chars */
2268ecb_inline int 2266ecb_inline int
2269is_one_of (char *s, int c) 2267is_one_of (const char *s, int c)
2270{ 2268{
2271 if (c == EOF) 2269 if (c == EOF)
2272 return 1; 2270 return 1;
2273 2271
2274 return !!strchr (s, c); 2272 return !!strchr (s, c);
… …
2330 2328
2331 if (is_one_of (" \n\t", c)) 2329 if (is_one_of (" \n\t", c))
2332 return TOK_DOT; 2330 return TOK_DOT;
2333 else 2331 else
2334 { 2332 {
2335 //TODO: ungetc twice in a row is not supported in C
2336 backchar (SCHEME_A_ c); 2333 backchar (SCHEME_A_ c);
2337 backchar (SCHEME_A_ '.');
2338 return TOK_ATOM; 2334 return TOK_DOTATOM;
2339 } 2335 }
2336
2337 case '|':
2338 return TOK_STRATOM;
2340 2339
2341 case '\'': 2340 case '\'':
2342 return TOK_QUOTE; 2341 return TOK_QUOTE;
2343 2342
2344 case ';': 2343 case ';':
… …
2476 } 2475 }
2477 2476
2478 putcharacter (SCHEME_A_ '"'); 2477 putcharacter (SCHEME_A_ '"');
2479} 2478}
2480 2479
2481
2482/* print atoms */ 2480/* print atoms */
2483static void 2481static void
2484printatom (SCHEME_P_ pointer l, int f) 2482printatom (SCHEME_P_ pointer l, int f)
2485{ 2483{
2486 char *p; 2484 char *p;
2487 int len; 2485 int len;
2488 2486
2489 atom2str (SCHEME_A_ l, f, &p, &len); 2487 atom2str (SCHEME_A_ l, f, &p, &len);
2490 putchars (SCHEME_A_ p, len); 2488 putchars (SCHEME_A_ p, len);
2491} 2489}
2492
2493 2490
2494/* Uses internal buffer unless string pointer is already available */ 2491/* Uses internal buffer unless string pointer is already available */
2495static void 2492static void
2496atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2493atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2497{ 2494{
… …
2658#endif 2655#endif
2659 } 2656 }
2660 else if (is_continuation (l)) 2657 else if (is_continuation (l))
2661 p = "#<CONTINUATION>"; 2658 p = "#<CONTINUATION>";
2662 else 2659 else
2660 {
2661#if USE_PRINTF
2662 p = SCHEME_V->strbuff;
2663 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2664#else
2663 p = "#<ERROR>"; 2665 p = "#<ERROR>";
2666#endif
2667 }
2664 2668
2665 *pp = p; 2669 *pp = p;
2666 *plen = strlen (p); 2670 *plen = strlen (p);
2667} 2671}
2668 2672
… …
2812/* () is #t in R5RS */ 2816/* () is #t in R5RS */
2813#define is_true(p) ((p) != S_F) 2817#define is_true(p) ((p) != S_F)
2814#define is_false(p) ((p) == S_F) 2818#define is_false(p) ((p) == S_F)
2815 2819
2816/* ========== Environment implementation ========== */ 2820/* ========== Environment implementation ========== */
2817
2818#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2819
2820static int
2821hash_fn (const char *key, int table_size)
2822{
2823 const unsigned char *p = key;
2824 uint32_t hash = 2166136261;
2825
2826 while (*p)
2827 hash = (hash ^ *p++) * 16777619;
2828
2829 return hash % table_size;
2830}
2831#endif
2832 2821
2833#ifndef USE_ALIST_ENV 2822#ifndef USE_ALIST_ENV
2834 2823
2835/* 2824/*
2836 * In this implementation, each frame of the environment may be 2825 * In this implementation, each frame of the environment may be
… …
2853 2842
2854 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2843 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2855 setenvironment (SCHEME_V->envir); 2844 setenvironment (SCHEME_V->envir);
2856} 2845}
2857 2846
2847static uint32_t
2848sym_hash (pointer sym, uint32_t size)
2849{
2850 uintptr_t ptr = (uintptr_t)sym;
2851
2852#if 0
2853 /* table size is prime, so why mix */
2854 ptr += ptr >> 32;
2855 ptr += ptr >> 16;
2856 ptr += ptr >> 8;
2857#endif
2858
2859 return ptr % size;
2860}
2861
2858ecb_inline void 2862ecb_inline void
2859new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2863new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2860{ 2864{
2861 pointer slot = immutable_cons (variable, value); 2865 pointer slot = immutable_cons (variable, value);
2862 2866
2863 if (is_vector (car (env))) 2867 if (is_vector (car (env)))
2864 { 2868 {
2865 int location = hash_fn (symname (variable), veclength (car (env))); 2869 int location = sym_hash (variable, veclength (car (env)));
2866
2867 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); 2870 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2868 } 2871 }
2869 else 2872 else
2870 set_car (env, immutable_cons (slot, car (env))); 2873 set_car (env, immutable_cons (slot, car (env)));
2871} 2874}
2872 2875
2873static pointer 2876static pointer
2874find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2877find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2875{ 2878{
2876 pointer x, y; 2879 pointer x, y;
2877 int location;
2878 2880
2879 for (x = env; x != NIL; x = cdr (x)) 2881 for (x = env; x != NIL; x = cdr (x))
2880 { 2882 {
2881 if (is_vector (car (x))) 2883 if (is_vector (car (x)))
2882 { 2884 {
2883 location = hash_fn (symname (hdl), veclength (car (x))); 2885 int location = sym_hash (hdl, veclength (car (x)));
2884 y = vector_get (car (x), location); 2886 y = vector_get (car (x), location);
2885 } 2887 }
2886 else 2888 else
2887 y = car (x); 2889 y = car (x);
2888 2890
… …
2925 for (y = car (x); y != NIL; y = cdr (y)) 2927 for (y = car (x); y != NIL; y = cdr (y))
2926 if (caar (y) == hdl) 2928 if (caar (y) == hdl)
2927 break; 2929 break;
2928 2930
2929 if (y != NIL) 2931 if (y != NIL)
2932 return car (y);
2930 break; 2933 break;
2931 2934
2932 if (!all) 2935 if (!all)
2933 return NIL; 2936 break;
2934 } 2937 }
2935
2936 if (x != NIL)
2937 return car (y);
2938 2938
2939 return NIL; 2939 return NIL;
2940} 2940}
2941 2941
2942#endif /* USE_ALIST_ENV else */ 2942#endif /* USE_ALIST_ENV else */
… …
3383 } 3383 }
3384 else 3384 else
3385 s_return (SCHEME_V->code); 3385 s_return (SCHEME_V->code);
3386 3386
3387 case OP_E0ARGS: /* eval arguments */ 3387 case OP_E0ARGS: /* eval arguments */
3388 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3388 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3389 { 3389 {
3390 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3390 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3391 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3391 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3392 SCHEME_V->code = SCHEME_V->value; 3392 SCHEME_V->code = SCHEME_V->value;
3393 s_goto (OP_APPLY); 3393 s_goto (OP_APPLY);
… …
3654 case OP_LET2: /* let */ 3654 case OP_LET2: /* let */
3655 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3655 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3656 3656
3657 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 3657 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3658 y != NIL; x = cdr (x), y = cdr (y)) 3658 y != NIL; x = cdr (x), y = cdr (y))
3659 { if (is_pair(caar(x))){debug(SCHEME_A_ 0, SCHEME_V->code);};//D
3660 pointer z = caar (x);
3661 if(is_pair(z)) z = car(z);//D
3662 new_slot_in_env (SCHEME_A_ z, car (y));
3663 }
3659 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3664 //new_slot_in_env (SCHEME_A_ caar (x), car (y));
3660 3665
3661 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3666 if (is_symbol (car (SCHEME_V->code))) /* named let */
3662 { 3667 {
3663 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 3668 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3664 { 3669 {
… …
4391 } 4396 }
4392 4397
4393 case OP_VECLEN: /* vector-length */ 4398 case OP_VECLEN: /* vector-length */
4394 s_return (mk_integer (SCHEME_A_ veclength (x))); 4399 s_return (mk_integer (SCHEME_A_ veclength (x)));
4395 4400
4401 case OP_VECRESIZE:
4402 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4403 s_return (x);
4404
4396 case OP_VECREF: /* vector-ref */ 4405 case OP_VECREF: /* vector-ref */
4397 { 4406 {
4398 int index = ivalue_unchecked (cadr (args)); 4407 int index = ivalue_unchecked (cadr (args));
4399 4408
4400 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4409 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
… …
4955 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 4964 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4956 SCHEME_V->tok = token (SCHEME_A); 4965 SCHEME_V->tok = token (SCHEME_A);
4957 s_goto (OP_RDSEXPR); 4966 s_goto (OP_RDSEXPR);
4958 4967
4959 case TOK_ATOM: 4968 case TOK_ATOM:
4960 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 4969 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
4970
4971 case TOK_DOTATOM:
4972 SCHEME_V->strbuff[0] = '.';
4973 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
4974
4975 case TOK_STRATOM:
4976 x = readstrexp (SCHEME_A_ '|');
4977 //TODO: haven't checked whether the garbage collector could interfere
4978 s_return (mk_atom (SCHEME_A_ strvalue (x)));
4961 4979
4962 case TOK_DQUOTE: 4980 case TOK_DQUOTE:
4963 x = readstrexp (SCHEME_A); 4981 x = readstrexp (SCHEME_A_ '"');
4964 4982
4965 if (x == S_F) 4983 if (x == S_F)
4966 Error_0 ("Error reading string"); 4984 Error_0 ("Error reading string");
4967 4985
4968 setimmutable (x); 4986 setimmutable (x);
… …
4980 s_goto (OP_EVAL); 4998 s_goto (OP_EVAL);
4981 } 4999 }
4982 } 5000 }
4983 5001
4984 case TOK_SHARP_CONST: 5002 case TOK_SHARP_CONST:
4985 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 5003 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4986 Error_0 ("undefined sharp expression"); 5004 Error_0 ("undefined sharp expression");
4987 else 5005 else
4988 s_return (x); 5006 s_return (x);
4989 5007
4990 default: 5008 default:
… …
5212 5230
5213 case OP_CLOSUREP: /* closure? */ 5231 case OP_CLOSUREP: /* closure? */
5214 /* 5232 /*
5215 * Note, macro object is also a closure. 5233 * Note, macro object is also a closure.
5216 * Therefore, (closure? <#MACRO>) ==> #t 5234 * Therefore, (closure? <#MACRO>) ==> #t
5235 * (schmorp) well, obviously not, fix? TODO
5217 */ 5236 */
5218 s_retbool (is_closure (a)); 5237 s_retbool (is_closure (a));
5219 5238
5220 case OP_MACROP: /* macro? */ 5239 case OP_MACROP: /* macro? */
5221 s_retbool (is_macro (a)); 5240 s_retbool (is_macro (a));
… …
5462 5481
5463/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5482/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5464static int 5483static int
5465syntaxnum (pointer p) 5484syntaxnum (pointer p)
5466{ 5485{
5467 const char *s = strvalue (car (p)); 5486 const char *s = strvalue (p);
5468 5487
5469 switch (strlength (car (p))) 5488 switch (strlength (p))
5470 { 5489 {
5471 case 2: 5490 case 2:
5472 if (s[0] == 'i') 5491 if (s[0] == 'i')
5473 return OP_IF0; /* if */ 5492 return OP_IF0; /* if */
5474 else 5493 else
… …
5910# endif 5929# endif
5911 int fin; 5930 int fin;
5912 char *file_name = InitFile; 5931 char *file_name = InitFile;
5913 int retcode; 5932 int retcode;
5914 int isfile = 1; 5933 int isfile = 1;
5934 system ("ps v $PPID");//D
5915 5935
5916 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5936 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5917 { 5937 {
5918 xwrstr ("Usage: tinyscheme -?\n"); 5938 xwrstr ("Usage: tinyscheme -?\n");
5919 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 5939 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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