ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.7 by root, Wed Nov 25 22:12:59 2015 UTC vs.
Revision 1.8 by root, Wed Nov 25 22:36:25 2015 UTC

… …
621static int file_push (SCHEME_P_ const char *fname); 621static int file_push (SCHEME_P_ const char *fname);
622static void file_pop (SCHEME_P); 622static void file_pop (SCHEME_P);
623static int file_interactive (SCHEME_P); 623static int file_interactive (SCHEME_P);
624static INLINE int is_one_of (char *s, int c); 624static INLINE int is_one_of (char *s, int c);
625static int alloc_cellseg (SCHEME_P_ int n); 625static int alloc_cellseg (SCHEME_P_ int n);
626static long binary_decode (const char *s);
627static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 626static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
628static void finalize_cell (SCHEME_P_ pointer a); 627static void finalize_cell (SCHEME_P_ pointer a);
629static int count_consecutive_cells (pointer x, int needed); 628static int count_consecutive_cells (pointer x, int needed);
630static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 629static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
631static pointer mk_number (SCHEME_P_ const num n); 630static pointer mk_number (SCHEME_P_ const num n);
… …
885#else 884#else
886 return x == 0; 885 return x == 0;
887#endif 886#endif
888} 887}
889 888
890static long
891binary_decode (const char *s)
892{
893 long x = 0;
894
895 while (*s != 0 && (*s == '1' || *s == '0'))
896 {
897 x <<= 1;
898 x += *s - '0';
899 s++;
900 }
901
902 return x;
903}
904
905/* allocate new cell segment */ 889/* allocate new cell segment */
906static int 890static int
907alloc_cellseg (SCHEME_P_ int n) 891alloc_cellseg (SCHEME_P_ int n)
908{ 892{
909 pointer newp; 893 pointer newp;
… …
1320 } 1304 }
1321 1305
1322 return q; 1306 return q;
1323} 1307}
1324 1308
1325/* get new string */
1326INTERFACE pointer 1309INTERFACE pointer
1327mk_string (SCHEME_P_ const char *str) 1310mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1328{ 1311{
1329 return mk_counted_string (SCHEME_A_ str, strlen (str)); 1312 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1313
1314 set_typeflag (x, T_STRING | T_ATOM);
1315 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1316 strlength (x) = len;
1317 return x;
1330} 1318}
1331 1319
1332INTERFACE pointer 1320INTERFACE pointer
1333mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1321mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1334{ 1322{
… …
1339 strlength (x) = len; 1327 strlength (x) = len;
1340 return x; 1328 return x;
1341} 1329}
1342 1330
1343INTERFACE pointer 1331INTERFACE pointer
1344mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1332mk_string (SCHEME_P_ const char *str)
1345{ 1333{
1346 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1334 return mk_counted_string (SCHEME_A_ str, strlen (str));
1347
1348 set_typeflag (x, T_STRING | T_ATOM);
1349 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1350 strlength (x) = len;
1351 return x;
1352} 1335}
1353 1336
1354INTERFACE pointer 1337INTERFACE pointer
1355mk_vector (SCHEME_P_ uint32_t len) 1338mk_vector (SCHEME_P_ uint32_t len)
1356{ 1339{
… …
1393 1376
1394INTERFACE pointer 1377INTERFACE pointer
1395gensym (SCHEME_P) 1378gensym (SCHEME_P)
1396{ 1379{
1397 pointer x; 1380 pointer x;
1398 char name[40];
1399 1381
1400 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1382 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1401 { 1383 {
1402 strcpy (name, "gensym-"); 1384 char name[40] = "gensym-";
1403 xnum (name + 7, SCHEME_V->gensym_cnt); 1385 xnum (name + 7, SCHEME_V->gensym_cnt);
1404 1386
1405 /* first check oblist */ 1387 /* first check oblist */
1406 x = oblist_find_by_name (SCHEME_A_ name); 1388 x = oblist_find_by_name (SCHEME_A_ name);
1407 1389
1408 if (x != NIL) 1390 if (x == NIL)
1409 continue;
1410 else
1411 { 1391 {
1412 x = oblist_add_by_name (SCHEME_A_ name); 1392 x = oblist_add_by_name (SCHEME_A_ name);
1413 return x; 1393 return x;
1414 } 1394 }
1415 } 1395 }
… …
1424 char c, *p; 1404 char c, *p;
1425 int has_dec_point = 0; 1405 int has_dec_point = 0;
1426 int has_fp_exp = 0; 1406 int has_fp_exp = 0;
1427 1407
1428#if USE_COLON_HOOK 1408#if USE_COLON_HOOK
1429
1430 if ((p = strstr (q, "::")) != 0) 1409 if ((p = strstr (q, "::")) != 0)
1431 { 1410 {
1432 *p = 0; 1411 *p = 0;
1433 return cons (SCHEME_V->COLON_HOOK, 1412 return cons (SCHEME_V->COLON_HOOK,
1434 cons (cons (SCHEME_V->QUOTE, 1413 cons (cons (SCHEME_V->QUOTE,
1435 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1414 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1436 } 1415 }
1437
1438#endif 1416#endif
1439 1417
1440 p = q; 1418 p = q;
1441 c = *p++; 1419 c = *p++;
1442 1420
… …
1510 1488
1511 if (!strcmp (name, "t")) 1489 if (!strcmp (name, "t"))
1512 return S_T; 1490 return S_T;
1513 else if (!strcmp (name, "f")) 1491 else if (!strcmp (name, "f"))
1514 return S_F; 1492 return S_F;
1515 else if (*name == 'o') /* #o (octal) */
1516 {
1517 x = strtol (name + 1, 0, 8);
1518 return mk_integer (SCHEME_A_ x);
1519 }
1520 else if (*name == 'd') /* #d (decimal) */
1521 {
1522 x = strtol (name + 1, 0, 10);
1523 return mk_integer (SCHEME_A_ x);
1524 }
1525 else if (*name == 'x') /* #x (hex) */
1526 {
1527 x = strtol (name + 1, 0, 16);
1528 return mk_integer (SCHEME_A_ x);
1529 }
1530 else if (*name == 'b') /* #b (binary) */
1531 {
1532 x = binary_decode (name + 1);
1533 return mk_integer (SCHEME_A_ x);
1534 }
1535 else if (*name == '\\') /* #\w (character) */ 1493 else if (*name == '\\') /* #\w (character) */
1536 { 1494 {
1537 int c = 0; 1495 int c = 0;
1538 1496
1539 if (stricmp (name + 1, "space") == 0) 1497 if (stricmp (name + 1, "space") == 0)
… …
1566 return NIL; 1524 return NIL;
1567 1525
1568 return mk_character (SCHEME_A_ c); 1526 return mk_character (SCHEME_A_ c);
1569 } 1527 }
1570 else 1528 else
1529 {
1530 /* identify base by string index */
1531 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1532 char *base = strchr (baseidx, *name);
1533
1534 if (base)
1535 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1536
1571 return NIL; 1537 return NIL;
1538 }
1572} 1539}
1573 1540
1574/* ========== garbage collector ========== */ 1541/* ========== garbage collector ========== */
1575 1542
1576/*-- 1543/*--

Diff Legend

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