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.7 by root, Wed Nov 25 22:12:59 2015 UTC vs.
Revision 1.9 by root, Wed Nov 25 22:39:19 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
… …
1503 1481
1504/* make constant */ 1482/* make constant */
1505static pointer 1483static pointer
1506mk_sharp_const (SCHEME_P_ char *name) 1484mk_sharp_const (SCHEME_P_ char *name)
1507{ 1485{
1508 long x;
1509 char tmp[STRBUFFSIZE];
1510
1511 if (!strcmp (name, "t")) 1486 if (!strcmp (name, "t"))
1512 return S_T; 1487 return S_T;
1513 else if (!strcmp (name, "f")) 1488 else if (!strcmp (name, "f"))
1514 return S_F; 1489 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) */ 1490 else if (*name == '\\') /* #\w (character) */
1536 { 1491 {
1537 int c = 0; 1492 int c;
1538 1493
1539 if (stricmp (name + 1, "space") == 0) 1494 if (stricmp (name + 1, "space") == 0)
1540 c = ' '; 1495 c = ' ';
1541 else if (stricmp (name + 1, "newline") == 0) 1496 else if (stricmp (name + 1, "newline") == 0)
1542 c = '\n'; 1497 c = '\n';
… …
1544 c = '\r'; 1499 c = '\r';
1545 else if (stricmp (name + 1, "tab") == 0) 1500 else if (stricmp (name + 1, "tab") == 0)
1546 c = '\t'; 1501 c = '\t';
1547 else if (name[1] == 'x' && name[2] != 0) 1502 else if (name[1] == 'x' && name[2] != 0)
1548 { 1503 {
1549 int c1 = strtol (name + 2, 0, 16); 1504 long c1 = strtol (name + 2, 0, 16);
1550 1505
1551 if (c1 <= UCHAR_MAX) 1506 if (0 <= c1 && c1 <= UCHAR_MAX)
1552 c = c1; 1507 c = c1;
1553 else 1508 else
1554 return NIL; 1509 return NIL;
1555 1510 }
1556#if USE_ASCII_NAMES 1511#if USE_ASCII_NAMES
1557 }
1558 else if (is_ascii_name (name + 1, &c)) 1512 else if (is_ascii_name (name + 1, &c))
1559 {
1560 /* nothing */ 1513 /* nothing */;
1561#endif 1514#endif
1562 }
1563 else if (name[2] == 0) 1515 else if (name[2] == 0)
1564 c = name[1]; 1516 c = name[1];
1565 else 1517 else
1566 return NIL; 1518 return NIL;
1567 1519
1568 return mk_character (SCHEME_A_ c); 1520 return mk_character (SCHEME_A_ c);
1569 } 1521 }
1570 else 1522 else
1523 {
1524 /* identify base by string index */
1525 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1526 char *base = strchr (baseidx, *name);
1527
1528 if (base)
1529 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1530
1571 return NIL; 1531 return NIL;
1532 }
1572} 1533}
1573 1534
1574/* ========== garbage collector ========== */ 1535/* ========== garbage collector ========== */
1575 1536
1576/*-- 1537/*--

Diff Legend

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