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.4 by root, Wed Nov 25 10:49:29 2015 UTC vs.
Revision 1.13 by root, Thu Nov 26 07:59:42 2015 UTC

1 1/*
2/* T I N Y S C H E M E 1 . 4 1 2 * µscheme
3 *
4 * Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
5 * do as you want with this, attribution appreciated.
6 *
7 * Based opn tinyscheme-1.41 (original credits follow)
3 * Dimitrios Souflis (dsouflis@acm.org) 8 * Dimitrios Souflis (dsouflis@acm.org)
4 * Based on MiniScheme (original credits follow) 9 * Based on MiniScheme (original credits follow)
5 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) 10 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
6 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 11 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
7 * (MINISCM) This version has been modified by R.C. Secrist. 12 * (MINISCM) This version has been modified by R.C. Secrist.
… …
60#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
61#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
62#define S_SINK (&SCHEME_V->xsink) 67#define S_SINK (&SCHEME_V->xsink)
63#define S_EOF (&SCHEME_V->xEOF_OBJ) 68#define S_EOF (&SCHEME_V->xEOF_OBJ)
64 69
70/* should use libecb */
71#if __GNUC__ >= 4
72# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74# define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
75#endif
76
65#if !USE_MULTIPLICITY 77#if !USE_MULTIPLICITY
66static scheme sc; 78static scheme sc;
67#endif 79#endif
68 80
69static void 81static void
… …
128 c += 'a' - 'A'; 140 c += 'a' - 'A';
129 141
130 return c; 142 return c;
131} 143}
132 144
145static int
146xisdigit (char c)
147{
148 return c >= '0' && c <= '9';
149}
150
151#define toupper(c) xtoupper (c)
152#define tolower(c) xtolower (c)
153#define isdigit(c) xisdigit (c)
154
133#if USE_STRLWR 155#if USE_STRLWR
134static const char * 156static const char *
135strlwr (char *s) 157strlwr (char *s)
136{ 158{
137 const char *p = s; 159 const char *p = s;
… …
146} 168}
147#endif 169#endif
148 170
149#define stricmp(a,b) strcmp (a, b) 171#define stricmp(a,b) strcmp (a, b)
150#define strlwr(s) (s) 172#define strlwr(s) (s)
151#define toupper(c) xtoupper(c)
152#define tolower(c) xtolower(c)
153 173
154#ifndef prompt 174#ifndef prompt
155# define prompt "ts> " 175# define prompt "ts> "
156#endif 176#endif
157 177
… …
188#define T_SYNTAX 0x0010 208#define T_SYNTAX 0x0010
189#define T_IMMUTABLE 0x0020 209#define T_IMMUTABLE 0x0020
190#define T_ATOM 0x0040 /* only for gc */ 210#define T_ATOM 0x0040 /* only for gc */
191#define T_MARK 0x0080 /* only for gc */ 211#define T_MARK 0x0080 /* only for gc */
192 212
193static num num_add (num a, num b);
194static num num_mul (num a, num b); 213static num num_op (char op, num a, num b);
195static num num_div (num a, num b);
196static num num_intdiv (num a, num b); 214static num num_intdiv (num a, num b);
197static num num_sub (num a, num b);
198static num num_rem (num a, num b); 215static num num_rem (num a, num b);
199static num num_mod (num a, num b); 216static num num_mod (num a, num b);
200static int num_eq (num a, num b); 217static int num_eq (num a, num b);
201static int num_gt (num a, num b); 218static int num_gt (num a, num b);
202static int num_ge (num a, num b); 219static int num_ge (num a, num b);
… …
236is_vector (pointer p) 253is_vector (pointer p)
237{ 254{
238 return type (p) == T_VECTOR; 255 return type (p) == T_VECTOR;
239} 256}
240 257
258#define vecvalue(p) ((p)->object.vector.vvalue)
259#define veclength(p) ((p)->object.vector.length)
241INTERFACE void fill_vector (pointer vec, pointer obj); 260INTERFACE void fill_vector (pointer vec, pointer obj);
242INTERFACE uint32_t vector_length (pointer vec); 261INTERFACE uint32_t vector_length (pointer vec);
243INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 262INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 263INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245 264
… …
314{ 333{
315 return num_get_rvalue (p->object.number); 334 return num_get_rvalue (p->object.number);
316} 335}
317 336
318#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 337#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319#if USE_FLOAT 338#if USE_REAL
320# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 339# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321# define set_num_integer(p) (p)->object.number.is_fixnum=1; 340# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322# define set_num_real(p) (p)->object.number.is_fixnum=0; 341# define set_num_real(p) (p)->object.number.is_fixnum=0;
323#else 342#else
324# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 343# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
… …
354{ 373{
355 return type (p) == T_PAIR; 374 return type (p) == T_PAIR;
356} 375}
357 376
358#define car(p) ((p)->object.cons.car + 0) 377#define car(p) ((p)->object.cons.car + 0)
359#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 378#define cdr(p) ((p)->object.cons.cdr + 0)
360 379
361#define caar(p) car (car (p)) 380static pointer caar (pointer p) { return car (car (p)); }
362#define cadr(p) car (cdr (p)) 381static pointer cadr (pointer p) { return car (cdr (p)); }
363#define cdar(p) cdr (car (p)) 382static pointer cdar (pointer p) { return cdr (car (p)); }
364#define cddr(p) cdr (cdr (p)) 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
365 384
366#define cadar(p) car (cdr (car (p))) 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
367#define caddr(p) car (cdr (cdr (p))) 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
368#define cdaar(p) cdr (car (car (p))) 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
369 388
370INTERFACE void 389INTERFACE void
371set_car (pointer p, pointer q) 390set_car (pointer p, pointer q)
372{ 391{
373 p->object.cons.car = q; 392 p->object.cons.car = q;
… …
486 return type (p) == T_ENVIRONMENT; 505 return type (p) == T_ENVIRONMENT;
487} 506}
488 507
489#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 508#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490 509
491#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492#define is_atom(p) (typeflag (p) & T_ATOM) 510#define is_atom(p) (typeflag (p) & T_ATOM)
493#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 511#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
494#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 512#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495 513
496#define is_mark(p) (typeflag (p) & T_MARK) 514#define is_mark(p) (typeflag (p) & T_MARK)
497#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 515#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
498#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 516#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
499
500#if 0
501static int
502is_atom(pointer p)
503{
504 if (!is_atom1(p) != !is_atom2(p))
505 printf ("atoms disagree %x\n", typeflag(p));
506
507 return is_atom2(p);
508}
509#endif
510 517
511INTERFACE INLINE int 518INTERFACE INLINE int
512is_immutable (pointer p) 519is_immutable (pointer p)
513{ 520{
514 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 521 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
618static int file_push (SCHEME_P_ const char *fname); 625static int file_push (SCHEME_P_ const char *fname);
619static void file_pop (SCHEME_P); 626static void file_pop (SCHEME_P);
620static int file_interactive (SCHEME_P); 627static int file_interactive (SCHEME_P);
621static INLINE int is_one_of (char *s, int c); 628static INLINE int is_one_of (char *s, int c);
622static int alloc_cellseg (SCHEME_P_ int n); 629static int alloc_cellseg (SCHEME_P_ int n);
623static long binary_decode (const char *s);
624static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 630static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
625static void finalize_cell (SCHEME_P_ pointer a); 631static void finalize_cell (SCHEME_P_ pointer a);
626static int count_consecutive_cells (pointer x, int needed); 632static int count_consecutive_cells (pointer x, int needed);
627static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 633static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
628static pointer mk_number (SCHEME_P_ const num n); 634static pointer mk_number (SCHEME_P_ const num n);
… …
672static void assign_syntax (SCHEME_P_ const char *name); 678static void assign_syntax (SCHEME_P_ const char *name);
673static int syntaxnum (pointer p); 679static int syntaxnum (pointer p);
674static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 680static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
675 681
676static num 682static num
677num_add (num a, num b) 683num_op (char op, num a, num b)
678{ 684{
679 num ret; 685 num ret;
680 686
681 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 687 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
682 688
683 if (num_is_fixnum (ret)) 689 if (num_is_fixnum (ret))
684 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); 690 {
691 IVALUE av = num_get_ivalue (a);
692 IVALUE bv = num_get_ivalue (b);
693
694 switch (op)
695 {
696 case '+': av += bv; break;
697 case '-': av -= bv; break;
698 case '*': av *= bv; break;
699 case '/': av /= bv; break;
700 }
701
702 num_set_ivalue (ret, av);
703 }
685 else 704 else
686 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); 705 {
706 RVALUE av = num_get_rvalue (a);
707 RVALUE bv = num_get_rvalue (b);
687 708
688 return ret; 709 switch (op)
689} 710 {
711 case '+': av += bv; break;
712 case '-': av -= bv; break;
713 case '*': av *= bv; break;
714 case '/': av /= bv; break;
715 }
690 716
691static num 717 num_set_rvalue (ret, av);
692num_mul (num a, num b) 718 }
693{
694 num ret;
695
696 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
697
698 if (num_is_fixnum (ret))
699 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
700 else
701 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
702 719
703 return ret; 720 return ret;
704} 721}
705 722
706static num 723static num
… …
712 729
713 if (num_is_fixnum (ret)) 730 if (num_is_fixnum (ret))
714 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); 731 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
715 else 732 else
716 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); 733 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
717
718 return ret;
719}
720
721static num
722num_intdiv (num a, num b)
723{
724 num ret;
725
726 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
727
728 if (num_is_fixnum (ret))
729 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
730 else
731 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
732
733 return ret;
734}
735
736static num
737num_sub (num a, num b)
738{
739 num ret;
740
741 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
742
743 if (num_is_fixnum (ret))
744 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
745 else
746 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
747 734
748 return ret; 735 return ret;
749} 736}
750 737
751static num 738static num
… …
875#endif 862#endif
876 863
877static int 864static int
878is_zero_rvalue (RVALUE x) 865is_zero_rvalue (RVALUE x)
879{ 866{
880#if USE_FLOAT 867#if USE_REAL
881 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 868 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
882#else 869#else
883 return x == 0; 870 return x == 0;
884#endif 871#endif
885}
886
887static long
888binary_decode (const char *s)
889{
890 long x = 0;
891
892 while (*s != 0 && (*s == '1' || *s == '0'))
893 {
894 x <<= 1;
895 x += *s - '0';
896 s++;
897 }
898
899 return x;
900} 872}
901 873
902/* allocate new cell segment */ 874/* allocate new cell segment */
903static int 875static int
904alloc_cellseg (SCHEME_P_ int n) 876alloc_cellseg (SCHEME_P_ int n)
… …
978 950
979/* get new cell. parameter a, b is marked by gc. */ 951/* get new cell. parameter a, b is marked by gc. */
980static INLINE pointer 952static INLINE pointer
981get_cell_x (SCHEME_P_ pointer a, pointer b) 953get_cell_x (SCHEME_P_ pointer a, pointer b)
982{ 954{
983 if (SCHEME_V->free_cell == NIL) 955 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
984 { 956 {
985 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 957 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
986 return S_SINK; 958 return S_SINK;
987 959
988 if (SCHEME_V->free_cell == NIL) 960 if (SCHEME_V->free_cell == NIL)
… …
1132 1104
1133 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1105 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134 set_typeflag (x, T_SYMBOL); 1106 set_typeflag (x, T_SYMBOL);
1135 setimmutable (car (x)); 1107 setimmutable (car (x));
1136 1108
1137 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1109 location = hash_fn (name, veclength (SCHEME_V->oblist));
1138 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1110 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1139 return x; 1111 return x;
1140} 1112}
1141 1113
1142static INLINE pointer 1114static INLINE pointer
… …
1144{ 1116{
1145 int location; 1117 int location;
1146 pointer x; 1118 pointer x;
1147 char *s; 1119 char *s;
1148 1120
1149 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1121 location = hash_fn (name, veclength (SCHEME_V->oblist));
1150 1122
1151 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1123 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1152 { 1124 {
1153 s = symname (car (x)); 1125 s = symname (car (x));
1154 1126
… …
1165{ 1137{
1166 int i; 1138 int i;
1167 pointer x; 1139 pointer x;
1168 pointer ob_list = NIL; 1140 pointer ob_list = NIL;
1169 1141
1170 for (i = 0; i < vector_length (SCHEME_V->oblist); i++) 1142 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1143 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1172 ob_list = cons (x, ob_list); 1144 ob_list = cons (x, ob_list);
1173 1145
1174 return ob_list; 1146 return ob_list;
1175} 1147}
… …
1317 } 1289 }
1318 1290
1319 return q; 1291 return q;
1320} 1292}
1321 1293
1322/* get new string */
1323INTERFACE pointer 1294INTERFACE pointer
1324mk_string (SCHEME_P_ const char *str) 1295mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1325{ 1296{
1326 return mk_counted_string (SCHEME_A_ str, strlen (str)); 1297 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1298
1299 set_typeflag (x, T_STRING | T_ATOM);
1300 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1301 strlength (x) = len;
1302 return x;
1327} 1303}
1328 1304
1329INTERFACE pointer 1305INTERFACE pointer
1330mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1306mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331{ 1307{
… …
1336 strlength (x) = len; 1312 strlength (x) = len;
1337 return x; 1313 return x;
1338} 1314}
1339 1315
1340INTERFACE pointer 1316INTERFACE pointer
1341mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1317mk_string (SCHEME_P_ const char *str)
1342{ 1318{
1343 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1319 return mk_counted_string (SCHEME_A_ str, strlen (str));
1344
1345 set_typeflag (x, T_STRING | T_ATOM);
1346 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1347 strlength (x) = len;
1348 return x;
1349} 1320}
1350 1321
1351INTERFACE pointer 1322INTERFACE pointer
1352mk_vector (SCHEME_P_ uint32_t len) 1323mk_vector (SCHEME_P_ uint32_t len)
1353{ 1324{
… …
1358fill_vector (pointer vec, pointer obj) 1329fill_vector (pointer vec, pointer obj)
1359{ 1330{
1360 int i; 1331 int i;
1361 1332
1362 for (i = 0; i < vec->object.vector.length; i++) 1333 for (i = 0; i < vec->object.vector.length; i++)
1363 vec->object.vector.vvalue[i] = obj; 1334 vecvalue (vec)[i] = obj;
1364} 1335}
1365 1336
1366INTERFACE pointer 1337INTERFACE pointer
1367vector_elem (pointer vec, uint32_t ielem) 1338vector_elem (pointer vec, uint32_t ielem)
1368{ 1339{
1369 return vec->object.vector.vvalue[ielem]; 1340 return vecvalue(vec)[ielem];
1370} 1341}
1371 1342
1372INTERFACE void 1343INTERFACE void
1373set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1344set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374{ 1345{
1375 vec->object.vector.vvalue[ielem] = a; 1346 vecvalue(vec)[ielem] = a;
1376} 1347}
1377 1348
1378/* get new symbol */ 1349/* get new symbol */
1379INTERFACE pointer 1350INTERFACE pointer
1380mk_symbol (SCHEME_P_ const char *name) 1351mk_symbol (SCHEME_P_ const char *name)
… …
1390 1361
1391INTERFACE pointer 1362INTERFACE pointer
1392gensym (SCHEME_P) 1363gensym (SCHEME_P)
1393{ 1364{
1394 pointer x; 1365 pointer x;
1395 char name[40];
1396 1366
1397 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1367 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398 { 1368 {
1399 strcpy (name, "gensym-"); 1369 char name[40] = "gensym-";
1400 xnum (name + 7, SCHEME_V->gensym_cnt); 1370 xnum (name + 7, SCHEME_V->gensym_cnt);
1401 1371
1402 /* first check oblist */ 1372 /* first check oblist */
1403 x = oblist_find_by_name (SCHEME_A_ name); 1373 x = oblist_find_by_name (SCHEME_A_ name);
1404 1374
1405 if (x != NIL) 1375 if (x == NIL)
1406 continue;
1407 else
1408 { 1376 {
1409 x = oblist_add_by_name (SCHEME_A_ name); 1377 x = oblist_add_by_name (SCHEME_A_ name);
1410 return x; 1378 return x;
1411 } 1379 }
1412 } 1380 }
… …
1421 char c, *p; 1389 char c, *p;
1422 int has_dec_point = 0; 1390 int has_dec_point = 0;
1423 int has_fp_exp = 0; 1391 int has_fp_exp = 0;
1424 1392
1425#if USE_COLON_HOOK 1393#if USE_COLON_HOOK
1426
1427 if ((p = strstr (q, "::")) != 0) 1394 if ((p = strstr (q, "::")) != 0)
1428 { 1395 {
1429 *p = 0; 1396 *p = 0;
1430 return cons (SCHEME_V->COLON_HOOK, 1397 return cons (SCHEME_V->COLON_HOOK,
1431 cons (cons (SCHEME_V->QUOTE, 1398 cons (cons (SCHEME_V->QUOTE,
1432 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1399 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1433 } 1400 }
1434
1435#endif 1401#endif
1436 1402
1437 p = q; 1403 p = q;
1438 c = *p++; 1404 c = *p++;
1439 1405
… …
1488 1454
1489 return mk_symbol (SCHEME_A_ strlwr (q)); 1455 return mk_symbol (SCHEME_A_ strlwr (q));
1490 } 1456 }
1491 } 1457 }
1492 1458
1493#if USE_FLOAT 1459#if USE_REAL
1494 if (has_dec_point) 1460 if (has_dec_point)
1495 return mk_real (SCHEME_A_ atof (q)); 1461 return mk_real (SCHEME_A_ atof (q));
1496#endif 1462#endif
1497 1463
1498 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1464 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
… …
1500 1466
1501/* make constant */ 1467/* make constant */
1502static pointer 1468static pointer
1503mk_sharp_const (SCHEME_P_ char *name) 1469mk_sharp_const (SCHEME_P_ char *name)
1504{ 1470{
1505 long x;
1506 char tmp[STRBUFFSIZE];
1507
1508 if (!strcmp (name, "t")) 1471 if (!strcmp (name, "t"))
1509 return S_T; 1472 return S_T;
1510 else if (!strcmp (name, "f")) 1473 else if (!strcmp (name, "f"))
1511 return S_F; 1474 return S_F;
1512 else if (*name == 'o') /* #o (octal) */
1513 {
1514 x = strtol (name + 1, 0, 8);
1515 return mk_integer (SCHEME_A_ x);
1516 }
1517 else if (*name == 'd') /* #d (decimal) */
1518 {
1519 x = strtol (name + 1, 0, 10);
1520 return mk_integer (SCHEME_A_ x);
1521 }
1522 else if (*name == 'x') /* #x (hex) */
1523 {
1524 x = strtol (name + 1, 0, 16);
1525 return mk_integer (SCHEME_A_ x);
1526 }
1527 else if (*name == 'b') /* #b (binary) */
1528 {
1529 x = binary_decode (name + 1);
1530 return mk_integer (SCHEME_A_ x);
1531 }
1532 else if (*name == '\\') /* #\w (character) */ 1475 else if (*name == '\\') /* #\w (character) */
1533 { 1476 {
1534 int c = 0; 1477 int c;
1535 1478
1536 if (stricmp (name + 1, "space") == 0) 1479 if (stricmp (name + 1, "space") == 0)
1537 c = ' '; 1480 c = ' ';
1538 else if (stricmp (name + 1, "newline") == 0) 1481 else if (stricmp (name + 1, "newline") == 0)
1539 c = '\n'; 1482 c = '\n';
… …
1541 c = '\r'; 1484 c = '\r';
1542 else if (stricmp (name + 1, "tab") == 0) 1485 else if (stricmp (name + 1, "tab") == 0)
1543 c = '\t'; 1486 c = '\t';
1544 else if (name[1] == 'x' && name[2] != 0) 1487 else if (name[1] == 'x' && name[2] != 0)
1545 { 1488 {
1546 int c1 = strtol (name + 2, 0, 16); 1489 long c1 = strtol (name + 2, 0, 16);
1547 1490
1548 if (c1 <= UCHAR_MAX) 1491 if (0 <= c1 && c1 <= UCHAR_MAX)
1549 c = c1; 1492 c = c1;
1550 else 1493 else
1551 return NIL; 1494 return NIL;
1552 1495 }
1553#if USE_ASCII_NAMES 1496#if USE_ASCII_NAMES
1554 }
1555 else if (is_ascii_name (name + 1, &c)) 1497 else if (is_ascii_name (name + 1, &c))
1556 {
1557 /* nothing */ 1498 /* nothing */;
1558#endif 1499#endif
1559 }
1560 else if (name[2] == 0) 1500 else if (name[2] == 0)
1561 c = name[1]; 1501 c = name[1];
1562 else 1502 else
1563 return NIL; 1503 return NIL;
1564 1504
1565 return mk_character (SCHEME_A_ c); 1505 return mk_character (SCHEME_A_ c);
1566 } 1506 }
1567 else 1507 else
1508 {
1509 /* identify base by string index */
1510 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1511 char *base = strchr (baseidx, *name);
1512
1513 if (base)
1514 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1515
1568 return NIL; 1516 return NIL;
1517 }
1569} 1518}
1570 1519
1571/* ========== garbage collector ========== */ 1520/* ========== garbage collector ========== */
1572 1521
1573/*-- 1522/*--
1574 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1523 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1575 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1524 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1576 * for marking. 1525 * for marking.
1526 *
1527 * The exception is vectors - vectors are currently marked recursively,
1528 * which is inherited form tinyscheme and could be fixed by having another
1529 * word of context in the vector
1577 */ 1530 */
1578static void 1531static void
1579mark (pointer a) 1532mark (pointer a)
1580{ 1533{
1581 pointer t, q, p; 1534 pointer t, q, p;
… …
1583 t = 0; 1536 t = 0;
1584 p = a; 1537 p = a;
1585E2: 1538E2:
1586 setmark (p); 1539 setmark (p);
1587 1540
1588 if (is_vector (p)) 1541 if (ecb_expect_false (is_vector (p)))
1589 { 1542 {
1590 int i; 1543 int i;
1591 1544
1592 for (i = 0; i < p->object.vector.length; i++) 1545 for (i = 0; i < p->object.vector.length; i++)
1593 mark (p->object.vector.vvalue[i]); 1546 mark (vecvalue (p)[i]);
1594 } 1547 }
1595 1548
1596 if (is_atom (p)) 1549 if (is_atom (p))
1597 goto E6; 1550 goto E6;
1598 1551
… …
1716} 1669}
1717 1670
1718static void 1671static void
1719finalize_cell (SCHEME_P_ pointer a) 1672finalize_cell (SCHEME_P_ pointer a)
1720{ 1673{
1674 /* TODO, fast bitmap check? */
1721 if (is_string (a)) 1675 if (is_string (a))
1722 free (strvalue (a)); 1676 free (strvalue (a));
1723 else if (is_vector (a)) 1677 else if (is_vector (a))
1724 free (a->object.vector.vvalue); 1678 free (vecvalue (a));
1725#if USE_PORTS 1679#if USE_PORTS
1726 else if (is_port (a)) 1680 else if (is_port (a))
1727 { 1681 {
1728 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1682 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729 port_close (SCHEME_A_ a, port_input | port_output); 1683 port_close (SCHEME_A_ a, port_input | port_output);
… …
2556 2510
2557 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2511 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2558 { 2512 {
2559 if (num_is_integer (l)) 2513 if (num_is_integer (l))
2560 xnum (p, ivalue_unchecked (l)); 2514 xnum (p, ivalue_unchecked (l));
2561#if USE_FLOAT 2515#if USE_REAL
2562 else 2516 else
2563 { 2517 {
2564 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2518 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565 /* r5rs says there must be a '.' (unless 'e'?) */ 2519 /* r5rs says there must be a '.' (unless 'e'?) */
2566 f = strcspn (p, ".e"); 2520 f = strcspn (p, ".e");
… …
2904{ 2858{
2905 pointer slot = immutable_cons (variable, value); 2859 pointer slot = immutable_cons (variable, value);
2906 2860
2907 if (is_vector (car (env))) 2861 if (is_vector (car (env)))
2908 { 2862 {
2909 int location = hash_fn (symname (variable), vector_length (car (env))); 2863 int location = hash_fn (symname (variable), veclength (car (env)));
2910 2864
2911 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2865 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2912 } 2866 }
2913 else 2867 else
2914 set_car (env, immutable_cons (slot, car (env))); 2868 set_car (env, immutable_cons (slot, car (env)));
… …
2922 2876
2923 for (x = env; x != NIL; x = cdr (x)) 2877 for (x = env; x != NIL; x = cdr (x))
2924 { 2878 {
2925 if (is_vector (car (x))) 2879 if (is_vector (car (x)))
2926 { 2880 {
2927 location = hash_fn (symname (hdl), vector_length (car (x))); 2881 location = hash_fn (symname (hdl), veclength (car (x)));
2928 y = vector_elem (car (x), location); 2882 y = vector_elem (car (x), location);
2929 } 2883 }
2930 else 2884 else
2931 y = car (x); 2885 y = car (x);
2932 2886
… …
3042#if USE_ERROR_HOOK 2996#if USE_ERROR_HOOK
3043 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2997 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044 2998
3045 if (x != NIL) 2999 if (x != NIL)
3046 { 3000 {
3047 if (a) 3001 pointer code = a
3048 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3002 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049 else 3003 : NIL;
3050 SCHEME_V->code = NIL;
3051 3004
3052 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3005 code = cons (mk_string (SCHEME_A_ s), code);
3053 setimmutable (car (SCHEME_V->code)); 3006 setimmutable (car (code));
3054 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3007 SCHEME_V->code = cons (slot_value_in_env (x), code);
3055 SCHEME_V->op = OP_EVAL; 3008 SCHEME_V->op = OP_EVAL;
3056 3009
3057 return S_T; 3010 return S_T;
3058 } 3011 }
3059#endif 3012#endif
… …
3350 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3303 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3304 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352 s_goto (OP_READ_INTERNAL); 3305 s_goto (OP_READ_INTERNAL);
3353 3306
3354 case OP_T1LVL: /* top level */ 3307 case OP_T1LVL: /* top level */
3355 SCHEME_V->code = SCHEME_V->value; 3308 SCHEME_V->code = SCHEME_V->value;
3356 SCHEME_V->inport = SCHEME_V->save_inport; 3309 SCHEME_V->inport = SCHEME_V->save_inport;
3357 s_goto (OP_EVAL); 3310 s_goto (OP_EVAL);
3358 3311
3359 case OP_READ_INTERNAL: /* internal read */ 3312 case OP_READ_INTERNAL: /* internal read */
3360 SCHEME_V->tok = token (SCHEME_A); 3313 SCHEME_V->tok = token (SCHEME_A);
… …
3410 else 3363 else
3411 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3364 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412 } 3365 }
3413 else if (is_pair (SCHEME_V->code)) 3366 else if (is_pair (SCHEME_V->code))
3414 { 3367 {
3368 x = car (SCHEME_V->code);
3369
3415 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3370 if (is_syntax (x)) /* SYNTAX */
3416 { 3371 {
3417 SCHEME_V->code = cdr (SCHEME_V->code); 3372 SCHEME_V->code = cdr (SCHEME_V->code);
3418 s_goto (syntaxnum (x)); 3373 s_goto (syntaxnum (x));
3419 } 3374 }
3420 else /* first, eval top element and eval arguments */ 3375 else /* first, eval top element and eval arguments */
3421 { 3376 {
3422 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3377 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3423 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3378 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424 SCHEME_V->code = car (SCHEME_V->code); 3379 SCHEME_V->code = x;
3425 s_goto (OP_EVAL); 3380 s_goto (OP_EVAL);
3426 } 3381 }
3427 } 3382 }
3428 else 3383 else
3429 s_return (SCHEME_V->code); 3384 s_return (SCHEME_V->code);
… …
3987 SCHEME_V->code = car (SCHEME_V->args); 3942 SCHEME_V->code = car (SCHEME_V->args);
3988 s_goto (OP_EVAL); 3943 s_goto (OP_EVAL);
3989 3944
3990 case OP_CONTINUATION: /* call-with-current-continuation */ 3945 case OP_CONTINUATION: /* call-with-current-continuation */
3991 SCHEME_V->code = car (SCHEME_V->args); 3946 SCHEME_V->code = car (SCHEME_V->args);
3992 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3947 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993 s_goto (OP_APPLY); 3948 s_goto (OP_APPLY);
3994 } 3949 }
3995 3950
3996 return S_T; 3951 return S_T;
3997} 3952}
… …
4130 4085
4131 case OP_ADD: /* + */ 4086 case OP_ADD: /* + */
4132 v = num_zero; 4087 v = num_zero;
4133 4088
4134 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4089 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4135 v = num_add (v, nvalue (car (x))); 4090 v = num_op ('+', v, nvalue (car (x)));
4136 4091
4137 s_return (mk_number (SCHEME_A_ v)); 4092 s_return (mk_number (SCHEME_A_ v));
4138 4093
4139 case OP_MUL: /* * */ 4094 case OP_MUL: /* * */
4140 v = num_one; 4095 v = num_one;
4141 4096
4142 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4097 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4143 v = num_mul (v, nvalue (car (x))); 4098 v = num_op ('+', v, nvalue (car (x)));
4144 4099
4145 s_return (mk_number (SCHEME_A_ v)); 4100 s_return (mk_number (SCHEME_A_ v));
4146 4101
4147 case OP_SUB: /* - */ 4102 case OP_SUB: /* - */
4148 if (cdr (SCHEME_V->args) == NIL) 4103 if (cdr (SCHEME_V->args) == NIL)
… …
4155 x = cdr (SCHEME_V->args); 4110 x = cdr (SCHEME_V->args);
4156 v = nvalue (car (SCHEME_V->args)); 4111 v = nvalue (car (SCHEME_V->args));
4157 } 4112 }
4158 4113
4159 for (; x != NIL; x = cdr (x)) 4114 for (; x != NIL; x = cdr (x))
4160 v = num_sub (v, nvalue (car (x))); 4115 v = num_op ('+', v, nvalue (car (x)));
4161 4116
4162 s_return (mk_number (SCHEME_A_ v)); 4117 s_return (mk_number (SCHEME_A_ v));
4163 4118
4164 case OP_DIV: /* / */ 4119 case OP_DIV: /* / */
4165 if (cdr (SCHEME_V->args) == NIL) 4120 if (cdr (SCHEME_V->args) == NIL)
… …
4196 } 4151 }
4197 4152
4198 for (; x != NIL; x = cdr (x)) 4153 for (; x != NIL; x = cdr (x))
4199 { 4154 {
4200 if (ivalue (car (x)) != 0) 4155 if (ivalue (car (x)) != 0)
4201 v = num_intdiv (v, nvalue (car (x))); 4156 v = num_op ('/', v, nvalue (car (x)));
4202 else 4157 else
4203 Error_0 ("quotient: division by zero"); 4158 Error_0 ("quotient: division by zero");
4204 } 4159 }
4205 4160
4206 s_return (mk_number (SCHEME_A_ v)); 4161 s_return (mk_number (SCHEME_A_ v));
… …
4505 4460
4506 s_return (vec); 4461 s_return (vec);
4507 } 4462 }
4508 4463
4509 case OP_VECLEN: /* vector-length */ 4464 case OP_VECLEN: /* vector-length */
4510 s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args)))); 4465 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511 4466
4512 case OP_VECREF: /* vector-ref */ 4467 case OP_VECREF: /* vector-ref */
4513 { 4468 {
4514 int index; 4469 int index;
4515 4470
4516 index = ivalue (cadr (SCHEME_V->args)); 4471 index = ivalue (cadr (SCHEME_V->args));
4517 4472
4518 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4473 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4474 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520 4475
4521 s_return (vector_elem (car (SCHEME_V->args), index)); 4476 s_return (vector_elem (car (SCHEME_V->args), index));
4522 } 4477 }
4523 4478
… …
4528 if (is_immutable (car (SCHEME_V->args))) 4483 if (is_immutable (car (SCHEME_V->args)))
4529 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4484 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4530 4485
4531 index = ivalue (cadr (SCHEME_V->args)); 4486 index = ivalue (cadr (SCHEME_V->args));
4532 4487
4533 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4488 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4489 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535 4490
4536 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4491 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4537 s_return (car (SCHEME_V->args)); 4492 s_return (car (SCHEME_V->args));
4538 } 4493 }
… …
5381 5336
5382 case OP_PVECFROM: 5337 case OP_PVECFROM:
5383 { 5338 {
5384 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5339 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385 pointer vec = car (SCHEME_V->args); 5340 pointer vec = car (SCHEME_V->args);
5386 int len = vector_length (vec); 5341 int len = veclength (vec);
5387 5342
5388 if (i == len) 5343 if (i == len)
5389 { 5344 {
5390 putstr (SCHEME_A_ ")"); 5345 putstr (SCHEME_A_ ")");
5391 s_return (S_T); 5346 s_return (S_T);
… …
5570 int ok = 1; 5525 int ok = 1;
5571 char msg[STRBUFFSIZE]; 5526 char msg[STRBUFFSIZE];
5572 int n = list_length (SCHEME_A_ SCHEME_V->args); 5527 int n = list_length (SCHEME_A_ SCHEME_V->args);
5573 5528
5574 /* Check number of arguments */ 5529 /* Check number of arguments */
5575 if (n < pcd->min_arity) 5530 if (ecb_expect_false (n < pcd->min_arity))
5576 { 5531 {
5577 ok = 0; 5532 ok = 0;
5578 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5533 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5579 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5534 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5580 } 5535 }
5581 5536 else if (ecb_excpect_false (n > pcd->max_arity))
5582 if (ok && n > pcd->max_arity)
5583 { 5537 {
5584 ok = 0; 5538 ok = 0;
5585 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5539 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5586 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5540 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5587 } 5541 }
5588 5542
5589 if (ok) 5543 if (ecb_expect_false (ok))
5590 { 5544 {
5591 if (pcd->arg_tests_encoding) 5545 if (pcd->arg_tests_encoding)
5592 { 5546 {
5593 int i = 0; 5547 int i = 0;
5594 int j; 5548 int j;
… …
5638 } 5592 }
5639#endif 5593#endif
5640 5594
5641 ok_to_freely_gc (SCHEME_A); 5595 ok_to_freely_gc (SCHEME_A);
5642 5596
5643 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5597 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5644 return; 5598 return;
5645 5599
5646#if USE_ERROR_CHECKING 5600 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647 if (SCHEME_V->no_memory)
5648 { 5601 {
5649 xwrstr ("No memory!\n"); 5602 xwrstr ("No memory!\n");
5650 return; 5603 return;
5651 } 5604 }
5652#endif
5653 } 5605 }
5654} 5606}
5655 5607
5656/* ========== Initialization of internal keywords ========== */ 5608/* ========== Initialization of internal keywords ========== */
5657 5609
… …
5708 5660
5709 case 'd': 5661 case 'd':
5710 return OP_COND0; /* cond */ 5662 return OP_COND0; /* cond */
5711 5663
5712 case '*': 5664 case '*':
5713 return OP_LET0AST; /* let* */ 5665 return OP_LET0AST;/* let* */
5714 5666
5715 default: 5667 default:
5716 return OP_SET0; /* set! */ 5668 return OP_SET0; /* set! */
5717 } 5669 }
5718 5670
… …
5740 5692
5741 case 'f': 5693 case 'f':
5742 return OP_DEF0; /* define */ 5694 return OP_DEF0; /* define */
5743 5695
5744 default: 5696 default:
5745 return OP_LET0REC; /* letrec */ 5697 return OP_LET0REC;/* letrec */
5746 } 5698 }
5747 5699
5748 default: 5700 default:
5749 return OP_C0STREAM; /* cons-stream */ 5701 return OP_C0STREAM; /* cons-stream */
5750 } 5702 }
… …
5817 set_cdr (S_T, S_T); 5769 set_cdr (S_T, S_T);
5818 /* init F */ 5770 /* init F */
5819 set_typeflag (S_F, T_ATOM | T_MARK); 5771 set_typeflag (S_F, T_ATOM | T_MARK);
5820 set_car (S_F, S_F); 5772 set_car (S_F, S_F);
5821 set_cdr (S_F, S_F); 5773 set_cdr (S_F, S_F);
5774 /* init EOF_OBJ */
5775 set_typeflag (S_EOF, T_ATOM | T_MARK);
5776 set_car (S_EOF, S_EOF);
5777 set_cdr (S_EOF, S_EOF);
5822 /* init sink */ 5778 /* init sink */
5823 set_typeflag (S_SINK, T_PAIR | T_MARK); 5779 set_typeflag (S_SINK, T_PAIR | T_MARK);
5824 set_car (S_SINK, NIL); 5780 set_car (S_SINK, NIL);
5781
5825 /* init c_nest */ 5782 /* init c_nest */
5826 SCHEME_V->c_nest = NIL; 5783 SCHEME_V->c_nest = NIL;
5827 5784
5828 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5785 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5829 /* init global_env */ 5786 /* init global_env */
… …
5847 for (i = 0; i < n; i++) 5804 for (i = 0; i < n; i++)
5848 if (dispatch_table[i].name != 0) 5805 if (dispatch_table[i].name != 0)
5849 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5806 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5850 5807
5851 /* initialization of global pointers to special symbols */ 5808 /* initialization of global pointers to special symbols */
5852 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5809 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5853 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5810 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5854 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5811 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5855 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5812 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5856 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5813 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5857 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5814 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5858 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5815 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5859 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5816 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5860 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5817 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5861 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5818 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5862 5819
5863 return !SCHEME_V->no_memory; 5820 return !SCHEME_V->no_memory;
5864} 5821}
5865 5822
… …
6112 6069
6113/* ========== Main ========== */ 6070/* ========== Main ========== */
6114 6071
6115#if STANDALONE 6072#if STANDALONE
6116 6073
6117# if defined(__APPLE__) && !defined (OSX)
6118int
6119main ()
6120{
6121 extern MacTS_main (int argc, char **argv);
6122 char **argv;
6123 int argc = ccommand (&argv);
6124
6125 MacTS_main (argc, argv);
6126 return 0;
6127}
6128
6129int
6130MacTS_main (int argc, char **argv)
6131{
6132# else
6133int 6074int
6134main (int argc, char **argv) 6075main (int argc, char **argv)
6135{ 6076{
6136# endif
6137# if USE_MULTIPLICITY 6077# if USE_MULTIPLICITY
6138 scheme ssc; 6078 scheme ssc;
6139 scheme *const SCHEME_V = &ssc; 6079 scheme *const SCHEME_V = &ssc;
6140# else 6080# else
6141# endif 6081# endif

Diff Legend

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