ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.52 by root, Tue Dec 1 01:56:22 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

…		…
91		91
92	#if !USE_MULTIPLICITY	92	#if !USE_MULTIPLICITY
93	static scheme sc;	93	static scheme sc;
94	#endif	94	#endif
95		95
96	static void	96	ecb_cold static void
97	xbase (char *s, long n, int base)	97	xbase (char *s, long n, int base)
98	{	98	{
99	if (n < 0)	99	if (n < 0)
100	{	100	{
101	*s++ = '-';	101	*s++ = '-';
…		…
103	}	103	}
104		104
105	char *p = s;	105	char *p = s;
106		106
107	do {	107	do {
108	*p++ = '0' + n % base;	108	*p++ = "0123456789abcdef"[n % base];
109	n /= base;	109	n /= base;
110	} while (n);	110	} while (n);
111		111
112	*p-- = 0;	112	*p-- = 0;
113		113
…		…
116	char x = *s; *s = *p; *p = x;	116	char x = *s; *s = *p; *p = x;
117	--p; ++s;	117	--p; ++s;
118	}	118	}
119	}	119	}
120		120
121	static void	121	ecb_cold static void
122	xnum (char *s, long n)	122	xnum (char *s, long n)
123	{	123	{
124	xbase (s, n, 10);	124	xbase (s, n, 10);
125	}	125	}
126		126
127	static void	127	ecb_cold static void
128	xwrstr (const char *s)	128	putnum (SCHEME_P_ long n)
129	{
130	write (1, s, strlen (s));
131	}
132
133	static void
134	xwrnum (long n)
135	{	129	{
136	char buf[64];	130	char buf[64];
137		131
138	xnum (buf, n);	132	xnum (buf, n);
139	xwrstr (buf);	133	putstr (SCHEME_A_ buf);
140	}	134	}
141		135
142	static char	136	ecb_cold static char
143	xtoupper (char c)	137	xtoupper (char c)
144	{	138	{
145	if (c >= 'a' && c <= 'z')	139	if (c >= 'a' && c <= 'z')
146	c -= 'a' - 'A';	140	c -= 'a' - 'A';
147		141
148	return c;	142	return c;
149	}	143	}
150		144
151	static char	145	ecb_cold static char
152	xtolower (char c)	146	xtolower (char c)
153	{	147	{
154	if (c >= 'A' && c <= 'Z')	148	if (c >= 'A' && c <= 'Z')
155	c += 'a' - 'A';	149	c += 'a' - 'A';
156		150
157	return c;	151	return c;
158	}	152	}
159		153
160	static int	154	ecb_cold static int
161	xisdigit (char c)	155	xisdigit (char c)
162	{	156	{
163	return c >= '0' && c <= '9';	157	return c >= '0' && c <= '9';
164	}	158	}
165		159
166	#define toupper(c) xtoupper (c)	160	#define toupper(c) xtoupper (c)
167	#define tolower(c) xtolower (c)	161	#define tolower(c) xtolower (c)
168	#define isdigit(c) xisdigit (c)	162	#define isdigit(c) xisdigit (c)
169		163
170	#if USE_IGNORECASE	164	#if USE_IGNORECASE
171	static const char *	165	ecb_cold static const char *
172	xstrlwr (char *s)	166	xstrlwr (char *s)
173	{	167	{
174	const char *p = s;	168	const char *p = s;
175		169
176	while (*s)	170	while (*s)
…		…
199	#endif	193	#endif
200		194
201	enum scheme_types	195	enum scheme_types
202	{	196	{
203	T_INTEGER,	197	T_INTEGER,
		198	T_CHARACTER,
204	T_REAL,	199	T_REAL,
205	T_STRING,	200	T_STRING,
206	T_SYMBOL,	201	T_SYMBOL,
207	T_PROC,	202	T_PROC,
208	T_PAIR, /* also used for free cells */	203	T_PAIR, /* also used for free cells */
209	T_CLOSURE,	204	T_CLOSURE,
		205	T_MACRO,
210	T_CONTINUATION,	206	T_CONTINUATION,
211	T_FOREIGN,	207	T_FOREIGN,
212	T_CHARACTER,
213	T_PORT,	208	T_PORT,
214	T_VECTOR,	209	T_VECTOR,
215	T_MACRO,
216	T_PROMISE,	210	T_PROMISE,
217	T_ENVIRONMENT,	211	T_ENVIRONMENT,
218	/* one more... */	212	/* one more... */
219	T_NUM_SYSTEM_TYPES	213	T_NUM_SYSTEM_TYPES
220	};	214	};
…		…
256	static num num_op (enum num_op op, num a, num b);	250	static num num_op (enum num_op op, num a, num b);
257	static num num_intdiv (num a, num b);	251	static num num_intdiv (num a, num b);
258	static num num_rem (num a, num b);	252	static num num_rem (num a, num b);
259	static num num_mod (num a, num b);	253	static num num_mod (num a, num b);
260		254
261	#if USE_MATH
262	static double round_per_R5RS (double x);
263	#endif
264	static int is_zero_rvalue (RVALUE x);	255	static int is_zero_rvalue (RVALUE x);
265		256
266	static num num_zero;	257	static num num_zero;
267	static num num_one;	258	static num num_one;
268		259
…		…
529	proper list: length	520	proper list: length
530	circular list: -1	521	circular list: -1
531	not even a pair: -2	522	not even a pair: -2
532	dotted list: -2 minus length before dot	523	dotted list: -2 minus length before dot
533	*/	524	*/
534	INTERFACE int	525	ecb_hot INTERFACE int
535	list_length (SCHEME_P_ pointer a)	526	list_length (SCHEME_P_ pointer a)
536	{	527	{
537	int i = 0;	528	int i = 0;
538	pointer slow, fast;	529	pointer slow, fast;
539		530
…		…
645	"gs",	636	"gs",
646	"rs",	637	"rs",
647	"us"	638	"us"
648	};	639	};
649		640
650	static int	641	ecb_cold static int
651	is_ascii_name (const char *name, int *pc)	642	is_ascii_name (const char *name, int *pc)
652	{	643	{
653	int i;	644	int i;
654		645
655	for (i = 0; i < 32; i++)	646	for (i = 0; i < 32; i++)
…		…
878	}	869	}
879		870
880	return ret;	871	return ret;
881	}	872	}
882		873
883	#if USE_MATH
884
885	/* Round to nearest. Round to even if midway */
886	static double
887	round_per_R5RS (double x)
888	{
889	double fl = floor (x);
890	double ce = ceil (x);
891	double dfl = x - fl;
892	double dce = ce - x;
893
894	if (dfl > dce)
895	return ce;
896	else if (dfl < dce)
897	return fl;
898	else
899	{
900	if (fmod (fl, 2) == 0) /* I imagine this holds */
901	return fl;
902	else
903	return ce;
904	}
905	}
906	#endif
907
908	static int	874	static int
909	is_zero_rvalue (RVALUE x)	875	is_zero_rvalue (RVALUE x)
910	{	876	{
911	return x == 0;	877	return x == 0;
912	#if 0	878	#if 0
…		…
917	#endif	883	#endif
918	#endif	884	#endif
919	}	885	}
920		886
921	/* allocate new cell segment */	887	/* allocate new cell segment */
922	static int	888	ecb_cold static int
923	alloc_cellseg (SCHEME_P)	889	alloc_cellseg (SCHEME_P)
924	{	890	{
925	struct cell *newp;	891	struct cell *newp;
926	struct cell *last;	892	struct cell *last;
927	struct cell *p;	893	struct cell *p;
…		…
998	}	964	}
999	}	965	}
1000		966
1001	/* To retain recent allocs before interpreter knows about them -	967	/* To retain recent allocs before interpreter knows about them -
1002	Tehom */	968	Tehom */
1003	static void	969	ecb_hot static void
1004	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1005	{	971	{
1006	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1007		973
1008	set_typeflag (holder, T_PAIR);	974	set_typeflag (holder, T_PAIR);
…		…
1010	set_car (holder, recent);	976	set_car (holder, recent);
1011	set_cdr (holder, car (S_SINK));	977	set_cdr (holder, car (S_SINK));
1012	set_car (S_SINK, holder);	978	set_car (S_SINK, holder);
1013	}	979	}
1014		980
1015	static pointer	981	ecb_hot static pointer
1016	get_cell (SCHEME_P_ pointer a, pointer b)	982	get_cell (SCHEME_P_ pointer a, pointer b)
1017	{	983	{
1018	pointer cell = get_cell_x (SCHEME_A_ a, b);	984	pointer cell = get_cell_x (SCHEME_A_ a, b);
1019		985
1020	/* For right now, include "a" and "b" in "cell" so that gc doesn't	986	/* For right now, include "a" and "b" in "cell" so that gc doesn't
…		…
1058	static void	1024	static void
1059	check_cell_alloced (pointer p, int expect_alloced)	1025	check_cell_alloced (pointer p, int expect_alloced)
1060	{	1026	{
1061	/* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */	1027	/* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1062	if (typeflag (p) & !expect_alloced)	1028	if (typeflag (p) & !expect_alloced)
1063	xwrstr ("Cell is already allocated!\n");	1029	putstr (SCHEME_A_ "Cell is already allocated!\n");
1064		1030
1065	if (!(typeflag (p)) & expect_alloced)	1031	if (!(typeflag (p)) & expect_alloced)
1066	xwrstr ("Cell is not allocated!\n");	1032	putstr (SCHEME_A_ "Cell is not allocated!\n");
1067	}	1033	}
1068		1034
1069	static void	1035	static void
1070	check_range_alloced (pointer p, int n, int expect_alloced)	1036	check_range_alloced (pointer p, int n, int expect_alloced)
1071	{	1037	{
…		…
1077	#endif	1043	#endif
1078		1044
1079	/* Medium level cell allocation */	1045	/* Medium level cell allocation */
1080		1046
1081	/* get new cons cell */	1047	/* get new cons cell */
1082	pointer	1048	ecb_hot pointer
1083	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1084	{	1050	{
1085	pointer x = get_cell (SCHEME_A_ a, b);	1051	pointer x = get_cell (SCHEME_A_ a, b);
1086		1052
1087	set_typeflag (x, T_PAIR);	1053	set_typeflag (x, T_PAIR);
…		…
1093	set_cdr (x, b);	1059	set_cdr (x, b);
1094		1060
1095	return x;	1061	return x;
1096	}	1062	}
1097		1063
1098	static pointer	1064	ecb_cold static pointer
1099	generate_symbol (SCHEME_P_ const char *name)	1065	generate_symbol (SCHEME_P_ const char *name)
1100	{	1066	{
1101	pointer x = mk_string (SCHEME_A_ name);	1067	pointer x = mk_string (SCHEME_A_ name);
1102	setimmutable (x);	1068	setimmutable (x);
1103	set_typeflag (x, T_SYMBOL | T_ATOM);	1069	set_typeflag (x, T_SYMBOL | T_ATOM);
…		…
1118	hash = (hash ^ *p++) * 16777619;	1084	hash = (hash ^ *p++) * 16777619;
1119		1085
1120	return hash % table_size;	1086	return hash % table_size;
1121	}	1087	}
1122		1088
1123	static pointer	1089	ecb_cold static pointer
1124	oblist_initial_value (SCHEME_P)	1090	oblist_initial_value (SCHEME_P)
1125	{	1091	{
1126	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1127	}	1093	}
1128		1094
1129	/* returns the new symbol */	1095	/* returns the new symbol */
1130	static pointer	1096	ecb_cold static pointer
1131	oblist_add_by_name (SCHEME_P_ const char *name)	1097	oblist_add_by_name (SCHEME_P_ const char *name)
1132	{	1098	{
1133	pointer x = generate_symbol (SCHEME_A_ name);	1099	pointer x = generate_symbol (SCHEME_A_ name);
1134	int location = hash_fn (name, veclength (SCHEME_V->oblist));	1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1135	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));	1101	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1136	return x;	1102	return x;
1137	}	1103	}
1138		1104
1139	ecb_inline pointer	1105	ecb_cold static pointer
1140	oblist_find_by_name (SCHEME_P_ const char *name)	1106	oblist_find_by_name (SCHEME_P_ const char *name)
1141	{	1107	{
1142	int location;	1108	int location;
1143	pointer x;	1109	pointer x;
1144	char *s;	1110	char *s;
…		…
1155	}	1121	}
1156		1122
1157	return NIL;	1123	return NIL;
1158	}	1124	}
1159		1125
1160	static pointer	1126	ecb_cold static pointer
1161	oblist_all_symbols (SCHEME_P)	1127	oblist_all_symbols (SCHEME_P)
1162	{	1128	{
1163	int i;	1129	int i;
1164	pointer x;	1130	pointer x;
1165	pointer ob_list = NIL;	1131	pointer ob_list = NIL;
…		…
1171	return ob_list;	1137	return ob_list;
1172	}	1138	}
1173		1139
1174	#else	1140	#else
1175		1141
1176	static pointer	1142	ecb_cold static pointer
1177	oblist_initial_value (SCHEME_P)	1143	oblist_initial_value (SCHEME_P)
1178	{	1144	{
1179	return NIL;	1145	return NIL;
1180	}	1146	}
1181		1147
1182	ecb_inline pointer	1148	ecb_cold static pointer
1183	oblist_find_by_name (SCHEME_P_ const char *name)	1149	oblist_find_by_name (SCHEME_P_ const char *name)
1184	{	1150	{
1185	pointer x;	1151	pointer x;
1186	char *s;	1152	char *s;
1187		1153
…		…
1196		1162
1197	return NIL;	1163	return NIL;
1198	}	1164	}
1199		1165
1200	/* returns the new symbol */	1166	/* returns the new symbol */
1201	static pointer	1167	ecb_cold static pointer
1202	oblist_add_by_name (SCHEME_P_ const char *name)	1168	oblist_add_by_name (SCHEME_P_ const char *name)
1203	{	1169	{
1204	pointer x = generate_symbol (SCHEME_A_ name);	1170	pointer x = generate_symbol (SCHEME_A_ name);
1205	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1206	return x;	1172	return x;
1207	}	1173	}
1208		1174
1209	static pointer	1175	ecb_cold static pointer
1210	oblist_all_symbols (SCHEME_P)	1176	oblist_all_symbols (SCHEME_P)
1211	{	1177	{
1212	return SCHEME_V->oblist;	1178	return SCHEME_V->oblist;
1213	}	1179	}
1214		1180
1215	#endif	1181	#endif
1216		1182
1217	#if USE_PORTS	1183	#if USE_PORTS
1218	static pointer	1184	ecb_cold static pointer
1219	mk_port (SCHEME_P_ port *p)	1185	mk_port (SCHEME_P_ port *p)
1220	{	1186	{
1221	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1222		1188
1223	set_typeflag (x, T_PORT | T_ATOM);	1189	set_typeflag (x, T_PORT | T_ATOM);
…		…
1225		1191
1226	return x;	1192	return x;
1227	}	1193	}
1228	#endif	1194	#endif
1229		1195
1230	pointer	1196	ecb_cold pointer
1231	mk_foreign_func (SCHEME_P_ foreign_func f)	1197	mk_foreign_func (SCHEME_P_ foreign_func f)
1232	{	1198	{
1233	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1234		1200
1235	set_typeflag (x, T_FOREIGN | T_ATOM);	1201	set_typeflag (x, T_FOREIGN | T_ATOM);
…		…
1400	x = oblist_add_by_name (SCHEME_A_ name);	1366	x = oblist_add_by_name (SCHEME_A_ name);
1401		1367
1402	return x;	1368	return x;
1403	}	1369	}
1404		1370
1405	INTERFACE pointer	1371	ecb_cold INTERFACE pointer
1406	gensym (SCHEME_P)	1372	gensym (SCHEME_P)
1407	{	1373	{
1408	pointer x;	1374	pointer x;
1409	char name[40] = "gensym-";	1375	char name[40] = "gensym-";
1410	xnum (name + 7, ++SCHEME_V->gensym_cnt);	1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);
…		…
1417	{	1383	{
1418	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;	1384	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1419	}	1385	}
1420		1386
1421	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1422	static pointer	1388	ecb_cold static pointer
1423	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
1424	{	1390	{
1425	char c, *p;	1391	char c, *p;
1426	int has_dec_point = 0;	1392	int has_dec_point = 0;
1427	int has_fp_exp = 0;	1393	int has_fp_exp = 0;
…		…
1498		1464
1499	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1500	}	1466	}
1501		1467
1502	/* make constant */	1468	/* make constant */
1503	static pointer	1469	ecb_cold static pointer
1504	mk_sharp_const (SCHEME_P_ char *name)	1470	mk_sharp_const (SCHEME_P_ char *name)
1505	{	1471	{
1506	if (!strcmp (name, "t"))	1472	if (!strcmp (name, "t"))
1507	return S_T;	1473	return S_T;
1508	else if (!strcmp (name, "f"))	1474	else if (!strcmp (name, "f"))
1509	return S_F;	1475	return S_F;
1510	else if (*name == '\\') /* #\w (character) */	1476	else if (*name == '\\') /* #\w (character) */
1511	{	1477	{
1512	int c;	1478	int c;
1513		1479
		1480	// TODO: optimise
1514	if (stricmp (name + 1, "space") == 0)	1481	if (stricmp (name + 1, "space") == 0)
1515	c = ' ';	1482	c = ' ';
1516	else if (stricmp (name + 1, "newline") == 0)	1483	else if (stricmp (name + 1, "newline") == 0)
1517	c = '\n';	1484	c = '\n';
1518	else if (stricmp (name + 1, "return") == 0)	1485	else if (stricmp (name + 1, "return") == 0)
1519	c = '\r';	1486	c = '\r';
1520	else if (stricmp (name + 1, "tab") == 0)	1487	else if (stricmp (name + 1, "tab") == 0)
1521	c = '\t';	1488	c = '\t';
		1489	else if (stricmp (name + 1, "alarm") == 0)
		1490	c = 0x07;
		1491	else if (stricmp (name + 1, "backspace") == 0)
		1492	c = 0x08;
		1493	else if (stricmp (name + 1, "escape") == 0)
		1494	c = 0x1b;
		1495	else if (stricmp (name + 1, "delete") == 0)
		1496	c = 0x7f;
		1497	else if (stricmp (name + 1, "null") == 0)
		1498	c = 0;
1522	else if (name[1] == 'x' && name[2] != 0)	1499	else if (name[1] == 'x' && name[2] != 0)
1523	{	1500	{
1524	long c1 = strtol (name + 2, 0, 16);	1501	long c1 = strtol (name + 2, 0, 16);
1525		1502
1526	if (0 <= c1 && c1 <= UCHAR_MAX)	1503	if (0 <= c1 && c1 <= UCHAR_MAX)
…		…
1551	return NIL;	1528	return NIL;
1552	}	1529	}
1553	}	1530	}
1554		1531
1555	/* ========== garbage collector ========== */	1532	/* ========== garbage collector ========== */
		1533
		1534	static void
		1535	finalize_cell (SCHEME_P_ pointer a)
		1536	{
		1537	/* TODO, fast bitmap check? */
		1538	if (is_string (a) || is_symbol (a))
		1539	free (strvalue (a));
		1540	else if (is_vector (a))
		1541	free (vecvalue (a));
		1542	#if USE_PORTS
		1543	else if (is_port (a))
		1544	{
		1545	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
		1546	port_close (SCHEME_A_ a, port_input | port_output);
		1547
		1548	free (port (a));
		1549	}
		1550	#endif
		1551	}
1556		1552
1557	/*--	1553	/*--
1558	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,	1554	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1559	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1560	* for marking.	1556	* for marking.
1561	*	1557	*
1562	* The exception is vectors - vectors are currently marked recursively,	1558	* The exception is vectors - vectors are currently marked recursively,
1563	* which is inherited form tinyscheme and could be fixed by having another	1559	* which is inherited form tinyscheme and could be fixed by having another
1564	* word of context in the vector	1560	* word of context in the vector
1565	*/	1561	*/
1566	static void	1562	ecb_hot static void
1567	mark (pointer a)	1563	mark (pointer a)
1568	{	1564	{
1569	pointer t, q, p;	1565	pointer t, q, p;
1570		1566
1571	t = 0;	1567	t = 0;
…		…
1628	p = q;	1624	p = q;
1629	goto E6;	1625	goto E6;
1630	}	1626	}
1631	}	1627	}
1632		1628
1633	/* garbage collection. parameter a, b is marked. */	1629	ecb_hot static void
1634	static void	1630	gc_free (SCHEME_P)
1635	gc (SCHEME_P_ pointer a, pointer b)
1636	{	1631	{
1637	int i;	1632	int i;
1638
1639	if (SCHEME_V->gc_verbose)
1640	putstr (SCHEME_A_ "gc...");
1641
1642	/* mark system globals */
1643	mark (SCHEME_V->oblist);
1644	mark (SCHEME_V->global_env);
1645
1646	/* mark current registers */
1647	mark (SCHEME_V->args);
1648	mark (SCHEME_V->envir);
1649	mark (SCHEME_V->code);
1650	dump_stack_mark (SCHEME_A);
1651	mark (SCHEME_V->value);
1652	mark (SCHEME_V->inport);
1653	mark (SCHEME_V->save_inport);
1654	mark (SCHEME_V->outport);
1655	mark (SCHEME_V->loadport);
1656
1657	/* Mark recent objects the interpreter doesn't know about yet. */
1658	mark (car (S_SINK));
1659	/* Mark any older stuff above nested C calls */
1660	mark (SCHEME_V->c_nest);
1661
1662	#if USE_INTCACHE
1663	/* mark intcache */
1664	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1665	if (SCHEME_V->intcache[i - INTCACHE_MIN])
1666	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1667	#endif
1668
1669	/* mark variables a, b */
1670	mark (a);
1671	mark (b);
1672
1673	/* garbage collect */
1674	clrmark (NIL);
1675	SCHEME_V->fcells = 0;
1676	SCHEME_V->free_cell = NIL;
1677
1678	if (SCHEME_V->gc_verbose)
1679	xwrstr ("freeing...");
1680
1681	uint32_t total = 0;	1633	uint32_t total = 0;
1682		1634
1683	/* Here we scan the cells to build the free-list. */	1635	/* Here we scan the cells to build the free-list. */
1684	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)	1636	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1685	{	1637	{
…		…
1710	}	1662	}
1711	}	1663	}
1712		1664
1713	if (SCHEME_V->gc_verbose)	1665	if (SCHEME_V->gc_verbose)
1714	{	1666	{
1715	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");	1667	putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1716	}
1717	}
1718
1719	static void
1720	finalize_cell (SCHEME_P_ pointer a)
1721	{
1722	/* TODO, fast bitmap check? */
1723	if (is_string (a) || is_symbol (a))
1724	free (strvalue (a));
1725	else if (is_vector (a))
1726	free (vecvalue (a));
1727	#if USE_PORTS
1728	else if (is_port (a))
1729	{	1668	}
1730	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)	1669	}
1731	port_close (SCHEME_A_ a, port_input | port_output);
1732		1670
1733	free (port (a));	1671	/* garbage collection. parameter a, b is marked. */
1734	}	1672	ecb_cold static void
		1673	gc (SCHEME_P_ pointer a, pointer b)
		1674	{
		1675	int i;
		1676
		1677	if (SCHEME_V->gc_verbose)
		1678	putstr (SCHEME_A_ "gc...");
		1679
		1680	/* mark system globals */
		1681	mark (SCHEME_V->oblist);
		1682	mark (SCHEME_V->global_env);
		1683
		1684	/* mark current registers */
		1685	mark (SCHEME_V->args);
		1686	mark (SCHEME_V->envir);
		1687	mark (SCHEME_V->code);
		1688	dump_stack_mark (SCHEME_A);
		1689	mark (SCHEME_V->value);
		1690	mark (SCHEME_V->inport);
		1691	mark (SCHEME_V->save_inport);
		1692	mark (SCHEME_V->outport);
		1693	mark (SCHEME_V->loadport);
		1694
		1695	/* Mark recent objects the interpreter doesn't know about yet. */
		1696	mark (car (S_SINK));
		1697	/* Mark any older stuff above nested C calls */
		1698	mark (SCHEME_V->c_nest);
		1699
		1700	#if USE_INTCACHE
		1701	/* mark intcache */
		1702	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
		1703	if (SCHEME_V->intcache[i - INTCACHE_MIN])
		1704	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1735	#endif	1705	#endif
		1706
		1707	/* mark variables a, b */
		1708	mark (a);
		1709	mark (b);
		1710
		1711	/* garbage collect */
		1712	clrmark (NIL);
		1713	SCHEME_V->fcells = 0;
		1714	SCHEME_V->free_cell = NIL;
		1715
		1716	if (SCHEME_V->gc_verbose)
		1717	putstr (SCHEME_A_ "freeing...");
		1718
		1719	gc_free (SCHEME_A);
1736	}	1720	}
1737		1721
1738	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1739		1723
1740	static int	1724	ecb_cold static int
1741	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1742	{	1726	{
1743	#if USE_PORTS	1727	#if USE_PORTS
1744	int fin;	1728	int fin;
1745		1729
…		…
1771	#else	1755	#else
1772	return 1;	1756	return 1;
1773	#endif	1757	#endif
1774	}	1758	}
1775		1759
1776	static void	1760	ecb_cold static void
1777	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1778	{	1762	{
1779	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1780	{	1764	{
1781	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
…		…
1785	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1786	set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);	1770	set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1787	}	1771	}
1788	}	1772	}
1789		1773
1790	static int	1774	ecb_cold static int
1791	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1792	{	1776	{
1793	#if USE_PORTS	1777	#if USE_PORTS
1794	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1795	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
…		…
1798	return 0;	1782	return 0;
1799	#endif	1783	#endif
1800	}	1784	}
1801		1785
1802	#if USE_PORTS	1786	#if USE_PORTS
1803	static port *	1787	ecb_cold static port *
1804	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1805	{	1789	{
1806	int fd;	1790	int fd;
1807	int flags;	1791	int flags;
1808	char *rw;	1792	char *rw;
…		…
1831	# endif	1815	# endif
1832		1816
1833	return pt;	1817	return pt;
1834	}	1818	}
1835		1819
1836	static pointer	1820	ecb_cold static pointer
1837	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1838	{	1822	{
1839	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1840		1824
1841	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1842	return NIL;	1826	return NIL;
1843		1827
1844	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1845	}	1829	}
1846		1830
1847	static port *	1831	ecb_cold static port *
1848	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1849	{	1833	{
1850	port *pt = malloc (sizeof *pt);	1834	port *pt = malloc (sizeof *pt);
1851		1835
1852	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1857	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1858	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1859	return pt;	1843	return pt;
1860	}	1844	}
1861		1845
1862	static pointer	1846	ecb_cold static pointer
1863	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1864	{	1848	{
1865	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1866		1850
1867	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1868	return NIL;	1852	return NIL;
1869		1853
1870	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1871	}	1855	}
1872		1856
1873	static port *	1857	ecb_cold static port *
1874	port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)	1858	port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1875	{	1859	{
1876	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1877		1861
1878	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1884	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1885	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1886	return pt;	1870	return pt;
1887	}	1871	}
1888		1872
1889	static pointer	1873	ecb_cold static pointer
1890	port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)	1874	port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1891	{	1875	{
1892	port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);	1876	port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1893		1877
1894	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1897	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1898	}	1882	}
1899		1883
1900	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1901		1885
1902	static port *	1886	ecb_cold static port *
1903	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1904	{	1888	{
1905	char *start;	1889	char *start;
1906	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1907		1891
…		…
1921	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1922	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1923	return pt;	1907	return pt;
1924	}	1908	}
1925		1909
1926	static pointer	1910	ecb_cold static pointer
1927	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1928	{	1912	{
1929	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1930		1914
1931	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1932	return NIL;	1916	return NIL;
1933		1917
1934	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1935	}	1919	}
1936		1920
1937	static void	1921	ecb_cold static void
1938	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1939	{	1923	{
1940	port *pt = port (p);	1924	port *pt = port (p);
1941		1925
1942	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
…		…
2054	ungot = c;	2038	ungot = c;
2055	#endif	2039	#endif
2056	}	2040	}
2057		2041
2058	#if USE_PORTS	2042	#if USE_PORTS
2059	static int	2043	ecb_cold static int
2060	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2061	{	2045	{
2062	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2063	size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;	2047	size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2064	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2077	else	2061	else
2078	return 0;	2062	return 0;
2079	}	2063	}
2080	#endif	2064	#endif
2081		2065
2082	INTERFACE void	2066	ecb_cold INTERFACE void
2083	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2084	{	2068	{
2085	#if USE_PORTS	2069	#if USE_PORTS
2086	port *pt = port (SCHEME_V->outport);	2070	port *pt = port (SCHEME_V->outport);
2087		2071
…		…
2093	*pt->rep.string.curr++ = *s;	2077	*pt->rep.string.curr++ = *s;
2094	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))	2078	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2095	*pt->rep.string.curr++ = *s;	2079	*pt->rep.string.curr++ = *s;
2096		2080
2097	#else	2081	#else
2098	xwrstr (s);	2082	write (pt->rep.stdio.file, s, strlen (s));
2099	#endif	2083	#endif
2100	}	2084	}
2101		2085
2102	static void	2086	ecb_cold static void
2103	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2104	{	2088	{
2105	#if USE_PORTS	2089	#if USE_PORTS
2106	port *pt = port (SCHEME_V->outport);	2090	port *pt = port (SCHEME_V->outport);
2107		2091
…		…
2121	#else	2105	#else
2122	write (1, s, len);	2106	write (1, s, len);
2123	#endif	2107	#endif
2124	}	2108	}
2125		2109
2126	INTERFACE void	2110	ecb_cold INTERFACE void
2127	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2128	{	2112	{
2129	#if USE_PORTS	2113	#if USE_PORTS
2130	port *pt = port (SCHEME_V->outport);	2114	port *pt = port (SCHEME_V->outport);
2131		2115
…		…
2147	write (1, &c, 1);	2131	write (1, &c, 1);
2148	#endif	2132	#endif
2149	}	2133	}
2150		2134
2151	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2152	static char *	2136	ecb_cold static char *
2153	readstr_upto (SCHEME_P_ int skip, const char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2154	{	2138	{
2155	char *p = SCHEME_V->strbuff + skip;	2139	char *p = SCHEME_V->strbuff + skip;
2156		2140
2157	while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));	2141	while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
…		…
2166		2150
2167	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2168	}	2152	}
2169		2153
2170	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2171	static pointer	2155	ecb_cold static pointer
2172	readstrexp (SCHEME_P_ char delim)	2156	readstrexp (SCHEME_P_ char delim)
2173	{	2157	{
2174	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2175	int c;	2159	int c;
2176	int c1 = 0;	2160	int c1 = 0;
…		…
2209	case '7':	2193	case '7':
2210	state = st_oct1;	2194	state = st_oct1;
2211	c1 = c - '0';	2195	c1 = c - '0';
2212	break;	2196	break;
2213		2197
		2198	case 'a': *p++ = '\a'; state = st_ok; break;
		2199	case 'n': *p++ = '\n'; state = st_ok; break;
		2200	case 'r': *p++ = '\r'; state = st_ok; break;
		2201	case 't': *p++ = '\t'; state = st_ok; break;
		2202
		2203	//TODO: \whitespace eol whitespace
		2204
		2205	//TODO: x should end in ;, not two-digit hex
2214	case 'x':	2206	case 'x':
2215	case 'X':	2207	case 'X':
2216	state = st_x1;	2208	state = st_x1;
2217	c1 = 0;	2209	c1 = 0;
2218	break;
2219
2220	case 'n':
2221	*p++ = '\n';
2222	state = st_ok;
2223	break;
2224
2225	case 't':
2226	*p++ = '\t';
2227	state = st_ok;
2228	break;
2229
2230	case 'r':
2231	*p++ = '\r';
2232	state = st_ok;
2233	break;	2210	break;
2234		2211
2235	default:	2212	default:
2236	*p++ = c;	2213	*p++ = c;
2237	state = st_ok;	2214	state = st_ok;
…		…
2289	}	2266	}
2290	}	2267	}
2291	}	2268	}
2292		2269
2293	/* check c is in chars */	2270	/* check c is in chars */
2294	ecb_inline int	2271	ecb_cold int
2295	is_one_of (const char *s, int c)	2272	is_one_of (const char *s, int c)
2296	{	2273	{
2297	return c == EOF || !!strchr (s, c);	2274	return c == EOF || !!strchr (s, c);
2298	}	2275	}
2299		2276
2300	/* skip white characters */	2277	/* skip white characters */
2301	ecb_inline int	2278	ecb_cold int
2302	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2303	{	2280	{
2304	int c, curr_line = 0;	2281	int c, curr_line = 0;
2305		2282
2306	do	2283	do
…		…
2326	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2327	return 1;	2304	return 1;
2328	}	2305	}
2329		2306
2330	/* get token */	2307	/* get token */
2331	static int	2308	ecb_cold static int
2332	token (SCHEME_P)	2309	token (SCHEME_P)
2333	{	2310	{
2334	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2335		2312
2336	if (c == EOF)	2313	if (c == EOF)
…		…
2434	}	2411	}
2435		2412
2436	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2437	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2438		2415
2439	static void	2416	ecb_cold static void
2440	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2441	{	2418	{
2442	int i;	2419	int i;
2443	unsigned char *s = (unsigned char *) p;	2420	unsigned char *s = (unsigned char *) p;
2444		2421
…		…
2500		2477
2501	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2502	}	2479	}
2503		2480
2504	/* print atoms */	2481	/* print atoms */
2505	static void	2482	ecb_cold static void
2506	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2507	{	2484	{
2508	char *p;	2485	char *p;
2509	int len;	2486	int len;
2510		2487
2511	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2512	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2513	}	2490	}
2514		2491
2515	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2516	static void	2493	ecb_cold static void
2517	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2518	{	2495	{
2519	char *p;	2496	char *p;
2520		2497
2521	if (l == NIL)	2498	if (l == NIL)
…		…
2728	return car (d);	2705	return car (d);
2729		2706
2730	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2731	q = p;	2708	q = p;
2732		2709
2733	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2734	{	2711	{
2735	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2736		2713
2737	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2738	p = cdr (d);	2715	p = cdr (d);
2739	}	2716	}
2740		2717
2741	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2742	return q;	2719	return q;
2743	}	2720	}
2744		2721
2745	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2746	static pointer	2723	ecb_hot static pointer
2747	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2748	{	2725	{
2749	/* a must be checked by gc */	2726	/* a must be checked by gc */
2750	pointer p = NIL;	2727	pointer p = NIL;
2751		2728
…		…
2754		2731
2755	return p;	2732	return p;
2756	}	2733	}
2757		2734
2758	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2759	static pointer	2736	ecb_hot static pointer
2760	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2761	{	2738	{
2762	pointer result = term;	2739	pointer result = term;
2763	pointer p = list;	2740	pointer p = list;
2764		2741
…		…
2772		2749
2773	return result;	2750	return result;
2774	}	2751	}
2775		2752
2776	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2777	static pointer	2754	ecb_hot static pointer
2778	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2779	{	2756	{
2780	pointer result = a;	2757	pointer result = a;
2781	pointer p = b;	2758	pointer p = b;
2782		2759
…		…
2791		2768
2792	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2793	}	2770	}
2794		2771
2795	/* equivalence of atoms */	2772	/* equivalence of atoms */
2796	int	2773	ecb_hot int
2797	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2798	{	2775	{
2799	if (is_string (a))	2776	if (is_string (a))
2800	{	2777	{
2801	if (is_string (b))	2778	if (is_string (b))
…		…
2895	}	2872	}
2896	else	2873	else
2897	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2898	}	2875	}
2899		2876
2900	static pointer	2877	ecb_hot static pointer
2901	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2878	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2902	{	2879	{
2903	pointer x, y;	2880	pointer x, y;
2904		2881
2905	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
…		…
2926	return NIL;	2903	return NIL;
2927	}	2904	}
2928		2905
2929	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2930		2907
2931	ecb_inline void	2908	static void
2932	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2933	{	2910	{
2934	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2935	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2936	}	2913	}
2937		2914
2938	ecb_inline void	2915	static void
2939	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2916	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2940	{	2917	{
2941	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2942	}	2919	}
2943		2920
2944	static pointer	2921	ecb_hot static pointer
2945	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2922	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2946	{	2923	{
2947	pointer x, y;	2924	pointer x, y;
2948		2925
2949	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2963	return NIL;	2940	return NIL;
2964	}	2941	}
2965		2942
2966	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2967		2944
2968	ecb_inline void	2945	static void
2969	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2970	{	2947	{
2971	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2	2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2972	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2949	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2973	}	2950	}
2974		2951
2975	ecb_inline void	2952	static void
2976	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2977	{	2954	{
2978	set_cdr (slot, value);	2955	set_cdr (slot, value);
2979	}	2956	}
2980		2957
2981	ecb_inline pointer	2958	static pointer
2982	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2983	{	2960	{
2984	return cdr (slot);	2961	return cdr (slot);
2985	}	2962	}
2986		2963
2987	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2988		2965
2989	static int	2966	ecb_cold static int
2990	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2991	{	2968	{
2992	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2993	pointer x;	2970	pointer x;
2994	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3070	pointer code;	3047	pointer code;
3071	};	3048	};
3072		3049
3073	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3074		3051
3075	static void	3052	ecb_hot static void
3076	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3053	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3077	{	3054	{
3078	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3079	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3080		3057
…		…
3093	next_frame->code = code;	3070	next_frame->code = code;
3094		3071
3095	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3096	}	3073	}
3097		3074
3098	static int	3075	static ecb_hot int
3099	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3100	{	3077	{
3101	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3102	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3103		3080
…		…
3114	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3115		3092
3116	return 0;	3093	return 0;
3117	}	3094	}
3118		3095
3119	ecb_inline void	3096	ecb_cold void
3120	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3121	{	3098	{
3122	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3099	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3123	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3124	}	3101	}
3125		3102
3126	ecb_inline void	3103	ecb_cold void
3127	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3128	{	3105	{
3129	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3130	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3131	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3132	}	3109	}
3133		3110
3134	static void	3111	ecb_cold static void
3135	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3136	{	3113	{
3137	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3138	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3139	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3140	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3141	}	3118	}
3142		3119
3143	static void	3120	ecb_cold static void
3144	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3145	{	3122	{
3146	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3147	int i;	3124	int i;
3148		3125
…		…
3154	mark (frame->envir);	3131	mark (frame->envir);
3155	mark (frame->code);	3132	mark (frame->code);
3156	}	3133	}
3157	}	3134	}
3158		3135
3159	static pointer	3136	ecb_cold static pointer
3160	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3161	{	3138	{
3162	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3163	int i;	3140	int i;
3164		3141
…		…
3176	}	3153	}
3177		3154
3178	return cont;	3155	return cont;
3179	}	3156	}
3180		3157
3181	static void	3158	ecb_cold static void
3182	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3183	{	3160	{
3184	int i = 0;	3161	int i = 0;
3185	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3186		3163
…		…
3198	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3199	}	3176	}
3200		3177
3201	#else	3178	#else
3202		3179
3203	ecb_inline void	3180	ecb_cold void
3204	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3205	{	3182	{
3206	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3207	}	3184	}
3208		3185
3209	ecb_inline void	3186	ecb_cold void
3210	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3211	{	3188	{
3212	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3213	}	3190	}
3214		3191
3215	static void	3192	ecb_cold static void
3216	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3217	{	3194	{
3218	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3219	}	3196	}
3220		3197
3221	static int	3198	ecb_hot static int
3222	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3223	{	3200	{
3224	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3225		3202
3226	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
…		…
3236	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3237		3214
3238	return 0;	3215	return 0;
3239	}	3216	}
3240		3217
3241	static void	3218	ecb_hot static void
3242	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3219	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3243	{	3220	{
3244	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3245	cons (args,	3222	cons (args,
3246	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3247	cons (code,	3224	cons (code,
3248	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3249	}	3226	}
3250		3227
3251	static void	3228	ecb_cold static void
3252	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3253	{	3230	{
3254	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3255	}	3232	}
3256		3233
3257	static pointer	3234	ecb_cold static pointer
3258	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3259	{	3236	{
3260	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3261	}	3238	}
3262		3239
3263	static void	3240	ecb_cold static void
3264	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3265	{	3242	{
3266	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3267	}	3244	}
3268		3245
…		…
3326	break;	3303	break;
3327	}	3304	}
3328	}	3305	}
3329	#endif	3306	#endif
3330		3307
3331	static int	3308	/* syntax, eval, core, ... */
		3309	ecb_hot static int
3332	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3333	{	3311	{
3334	pointer args = SCHEME_V->args;	3312	pointer args = SCHEME_V->args;
3335	pointer x, y;	3313	pointer x, y;
3336		3314
…		…
3343	s_return (S_T);	3321	s_return (S_T);
3344	#endif	3322	#endif
3345	case OP_LOAD: /* load */	3323	case OP_LOAD: /* load */
3346	if (file_interactive (SCHEME_A))	3324	if (file_interactive (SCHEME_A))
3347	{	3325	{
3348	xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");	3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3349	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3350	}	3328	}
3351		3329
3352	if (!file_push (SCHEME_A_ strvalue (car (args))))	3330	if (!file_push (SCHEME_A_ strvalue (car (args))))
3353	Error_1 ("unable to open", car (args));	3331	Error_1 ("unable to open", car (args));
…		…
4022	}	4000	}
4023		4001
4024	if (USE_ERROR_CHECKING) abort ();	4002	if (USE_ERROR_CHECKING) abort ();
4025	}	4003	}
4026		4004
4027	static int	4005	/* math, cxr */
		4006	ecb_hot static int
4028	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4029	{	4008	{
4030	pointer args = SCHEME_V->args;	4009	pointer args = SCHEME_V->args;
4031	pointer x = car (args);	4010	pointer x = car (args);
4032	num v;	4011	num v;
4033		4012
4034	switch (op)	4013	switch (op)
4035	{	4014	{
4036	#if USE_MATH	4015	#if USE_MATH
4037	case OP_INEX2EX: /* inexact->exact */	4016	case OP_INEX2EX: /* inexact->exact */
4038	{
4039	if (is_integer (x))	4017	if (!is_integer (x))
4040	s_return (x);	4018	{
4041
4042	RVALUE r = rvalue_unchecked (x);	4019	RVALUE r = rvalue_unchecked (x);
4043		4020
4044	if (r == (RVALUE)(IVALUE)r)	4021	if (r == (RVALUE)(IVALUE)r)
4045	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));	4022	x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4046	else	4023	else
4047	Error_1 ("inexact->exact: not integral:", x);	4024	Error_1 ("inexact->exact: not integral:", x);
4048	}	4025	}
4049		4026
		4027	s_return (x);
		4028
		4029	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
		4030	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
		4031	case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
		4032	case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
		4033
		4034	case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4050	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	4035	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4051	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));	4036	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
		4037	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4052	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));	4038	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4053	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));	4039	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4054	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));	4040	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4055	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));	4041	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4056	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));	4042	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4057		4043
4058	case OP_ATAN:	4044	case OP_ATAN:
		4045	s_return (mk_real (SCHEME_A_
4059	if (cdr (args) == NIL)	4046	cdr (args) == NIL
4060	s_return (mk_real (SCHEME_A_ atan (rvalue (x))));	4047	? atan (rvalue (x))
4061	else	4048	: atan2 (rvalue (x), rvalue (cadr (args)))));
4062	{
4063	pointer y = cadr (args);
4064	s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4065	}
4066
4067	case OP_SQRT:
4068	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4069		4049
4070	case OP_EXPT:	4050	case OP_EXPT:
4071	{	4051	{
4072	RVALUE result;	4052	RVALUE result;
4073	int real_result = 1;	4053	int real_result = 1;
…		…
4096	if (real_result)	4076	if (real_result)
4097	s_return (mk_real (SCHEME_A_ result));	4077	s_return (mk_real (SCHEME_A_ result));
4098	else	4078	else
4099	s_return (mk_integer (SCHEME_A_ result));	4079	s_return (mk_integer (SCHEME_A_ result));
4100	}	4080	}
4101
4102	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4103	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4104
4105	case OP_TRUNCATE:
4106	{
4107	RVALUE n = rvalue (x);
4108	s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4109	}
4110
4111	case OP_ROUND:
4112	if (is_integer (x))
4113	s_return (x);
4114
4115	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4116	#endif	4081	#endif
4117		4082
4118	case OP_ADD: /* + */	4083	case OP_ADD: /* + */
4119	v = num_zero;	4084	v = num_zero;
4120		4085
…		…
4422	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4387	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4423		4388
4424	s_return (newstr);	4389	s_return (newstr);
4425	}	4390	}
4426		4391
4427	case OP_SUBSTR: /* substring */	4392	case OP_STRING_COPY: /* substring/string-copy */
4428	{	4393	{
4429	char *str = strvalue (x);	4394	char *str = strvalue (x);
4430	int index0 = ivalue_unchecked (cadr (args));	4395	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4431	int index1;	4396	int index1;
4432	int len;	4397	int len;
4433		4398
4434	if (index0 > strlength (x))	4399	if (index0 > strlength (x))
4435	Error_1 ("substring: start out of bounds:", cadr (args));	4400	Error_1 ("string->copy: start out of bounds:", cadr (args));
4436		4401
4437	if (cddr (args) != NIL)	4402	if (cddr (args) != NIL)
4438	{	4403	{
4439	index1 = ivalue_unchecked (caddr (args));	4404	index1 = ivalue_unchecked (caddr (args));
4440		4405
4441	if (index1 > strlength (x) || index1 < index0)	4406	if (index1 > strlength (x) || index1 < index0)
4442	Error_1 ("substring: end out of bounds:", caddr (args));	4407	Error_1 ("string->copy: end out of bounds:", caddr (args));
4443	}	4408	}
4444	else	4409	else
4445	index1 = strlength (x);	4410	index1 = strlength (x);
4446		4411
4447	len = index1 - index0;	4412	len = index1 - index0;
4448	x = mk_empty_string (SCHEME_A_ len, ' ');	4413	x = mk_counted_string (SCHEME_A_ str + index0, len);
4449	memcpy (strvalue (x), str + index0, len);
4450	strvalue (x)[len] = 0;
4451		4414
4452	s_return (x);	4415	s_return (x);
4453	}	4416	}
4454		4417
4455	case OP_VECTOR: /* vector */	4418	case OP_VECTOR: /* vector */
…		…
4529	}	4492	}
4530		4493
4531	if (USE_ERROR_CHECKING) abort ();	4494	if (USE_ERROR_CHECKING) abort ();
4532	}	4495	}
4533		4496
4534	static int	4497	/* relational ops */
		4498	ecb_hot static int
4535	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4499	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4536	{	4500	{
4537	pointer x = SCHEME_V->args;	4501	pointer x = SCHEME_V->args;
4538		4502
4539	for (;;)	4503	for (;;)
…		…
4560	}	4524	}
4561		4525
4562	s_return (S_T);	4526	s_return (S_T);
4563	}	4527	}
4564		4528
4565	static int	4529	/* predicates */
		4530	ecb_hot static int
4566	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4531	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4567	{	4532	{
4568	pointer args = SCHEME_V->args;	4533	pointer args = SCHEME_V->args;
4569	pointer a = car (args);	4534	pointer a = car (args);
4570	pointer d = cdr (args);	4535	pointer d = cdr (args);
…		…
4617	}	4582	}
4618		4583
4619	s_retbool (r);	4584	s_retbool (r);
4620	}	4585	}
4621		4586
4622	static int	4587	/* promises, list ops, ports */
		4588	ecb_hot static int
4623	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4589	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4624	{	4590	{
4625	pointer args = SCHEME_V->args;	4591	pointer args = SCHEME_V->args;
4626	pointer a = car (args);	4592	pointer a = car (args);
4627	pointer x, y;	4593	pointer x, y;
…		…
4644	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4610	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4645	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);	4611	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4646	s_return (SCHEME_V->value);	4612	s_return (SCHEME_V->value);
4647		4613
4648	#if USE_PORTS	4614	#if USE_PORTS
		4615
		4616	case OP_EOF_OBJECT: /* eof-object */
		4617	s_return (S_EOF);
4649		4618
4650	case OP_WRITE: /* write */	4619	case OP_WRITE: /* write */
4651	case OP_DISPLAY: /* display */	4620	case OP_DISPLAY: /* display */
4652	case OP_WRITE_CHAR: /* write-char */	4621	case OP_WRITE_CHAR: /* write-char */
4653	if (is_pair (cdr (SCHEME_V->args)))	4622	if (is_pair (cdr (SCHEME_V->args)))
…		…
4926	}	4895	}
4927		4896
4928	if (USE_ERROR_CHECKING) abort ();	4897	if (USE_ERROR_CHECKING) abort ();
4929	}	4898	}
4930		4899
4931	static int	4900	/* reading */
		4901	ecb_cold static int
4932	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4933	{	4903	{
4934	pointer args = SCHEME_V->args;	4904	pointer args = SCHEME_V->args;
4935	pointer x;	4905	pointer x;
4936		4906
…		…
5278	}	5248	}
5279		5249
5280	if (USE_ERROR_CHECKING) abort ();	5250	if (USE_ERROR_CHECKING) abort ();
5281	}	5251	}
5282		5252
5283	static int	5253	/* list ops */
		5254	ecb_hot static int
5284	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5285	{	5256	{
5286	pointer args = SCHEME_V->args;	5257	pointer args = SCHEME_V->args;
5287	pointer a = car (args);	5258	pointer a = car (args);
5288	pointer x, y;	5259	pointer x, y;
…		…
5346		5317
5347	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5318	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5348	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5349		5320
5350	typedef int (*test_predicate)(pointer);	5321	typedef int (*test_predicate)(pointer);
5351	static int	5322
		5323	ecb_hot static int
5352	tst_any (pointer p)	5324	tst_any (pointer p)
5353	{	5325	{
5354	return 1;	5326	return 1;
5355	}	5327	}
5356		5328
5357	static int	5329	ecb_hot static int
5358	tst_inonneg (pointer p)	5330	tst_inonneg (pointer p)
5359	{	5331	{
5360	return is_integer (p) && ivalue_unchecked (p) >= 0;	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
5361	}	5333	}
5362		5334
5363	static int	5335	ecb_hot static int
5364	tst_is_list (SCHEME_P_ pointer p)	5336	tst_is_list (SCHEME_P_ pointer p)
5365	{	5337	{
5366	return p == NIL || is_pair (p);	5338	return p == NIL || is_pair (p);
5367	}	5339	}
5368		5340
…		…
5411	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5412	#include "opdefines.h"	5384	#include "opdefines.h"
5413	#undef OP_DEF	5385	#undef OP_DEF
5414	;	5386	;
5415		5387
5416	static const char *	5388	ecb_cold static const char *
5417	opname (int idx)	5389	opname (int idx)
5418	{	5390	{
5419	const char *name = opnames;	5391	const char *name = opnames;
5420		5392
5421	/* should do this at compile time, but would require external program, right? */	5393	/* should do this at compile time, but would require external program, right? */
…		…
5423	name += strlen (name) + 1;	5395	name += strlen (name) + 1;
5424		5396
5425	return *name ? name : "ILLEGAL";	5397	return *name ? name : "ILLEGAL";
5426	}	5398	}
5427		5399
5428	static const char *	5400	ecb_cold static const char *
5429	procname (pointer x)	5401	procname (pointer x)
5430	{	5402	{
5431	return opname (procnum (x));	5403	return opname (procnum (x));
5432	}	5404	}
5433		5405
…		…
5453	#undef OP_DEF	5425	#undef OP_DEF
5454	{0}	5426	{0}
5455	};	5427	};
5456		5428
5457	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5458	static void ecb_hot	5430	ecb_hot static void
5459	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5460	{	5432	{
5461	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5462		5434
5463	for (;;)	5435	for (;;)
…		…
5546	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))	5518	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5547	return;	5519	return;
5548		5520
5549	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5521	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5550	{	5522	{
5551	xwrstr ("No memory!\n");	5523	putstr (SCHEME_A_ "No memory!\n");
5552	return;	5524	return;
5553	}	5525	}
5554	}	5526	}
5555	}	5527	}
5556		5528
5557	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5558		5530
5559	static void	5531	ecb_cold static void
5560	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5561	{	5533	{
5562	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5563	set_typeflag (x, typeflag (x) | T_SYNTAX);	5535	set_typeflag (x, typeflag (x) | T_SYNTAX);
5564	}	5536	}
5565		5537
5566	static void	5538	ecb_cold static void
5567	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5568	{	5540	{
5569	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5570	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5571	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5579	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5580	return y;	5552	return y;
5581	}	5553	}
5582		5554
5583	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5555	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5584	static int	5556	ecb_hot static int
5585	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5586	{	5558	{
5587	const char *s = strvalue (p);	5559	const char *s = strvalue (p);
5588		5560
5589	switch (strlength (p))	5561	switch (strlength (p))
…		…
5774		5746
5775	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5776	}	5748	}
5777		5749
5778	#if USE_PORTS	5750	#if USE_PORTS
5779	void	5751	ecb_cold void
5780	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5781	{	5753	{
5782	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5783	}	5755	}
5784		5756
5785	void	5757	ecb_cold void
5786	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)	5758	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5787	{	5759	{
5788	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);	5760	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5789	}	5761	}
5790		5762
5791	void	5763	ecb_cold void
5792	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5793	{	5765	{
5794	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5795	}	5767	}
5796		5768
5797	void	5769	ecb_cold void
5798	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)	5770	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5799	{	5771	{
5800	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);	5772	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5801	}	5773	}
5802	#endif	5774	#endif
5803		5775
5804	void	5776	ecb_cold void
5805	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5806	{	5778	{
5807	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5808	}	5780	}
5809		5781
…		…
5857	}	5829	}
5858	}	5830	}
5859	#endif	5831	#endif
5860	}	5832	}
5861		5833
5862	void	5834	ecb_cold void
5863	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5864	{	5836	{
5865	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5866	}	5838	}
5867		5839
5868	void	5840	ecb_cold void
5869	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5870	{	5842	{
5871	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5872	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5873	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5900		5872
5901	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5902	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5903	}	5875	}
5904		5876
5905	void	5877	ecb_cold void
5906	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5907	{	5879	{
5908	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5909	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5910	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
…		…
5924		5896
5925	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5926	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5927	}	5899	}
5928		5900
5929	void	5901	ecb_cold void
5930	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5931	{	5903	{
5932	pointer x;	5904	pointer x;
5933		5905
5934	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5939	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5940	}	5912	}
5941		5913
5942	#if !STANDALONE	5914	#if !STANDALONE
5943		5915
5944	void	5916	ecb_cold void
5945	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5946	{	5918	{
5947	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));	5919	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5948	}	5920	}
5949		5921
5950	void	5922	ecb_cold void
5951	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)	5923	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5952	{	5924	{
5953	int i;	5925	int i;
5954		5926
5955	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
5956	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
5957	}	5929	}
5958		5930
5959	pointer	5931	ecb_cold pointer
5960	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
5961	{	5933	{
5962	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));	5934	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5963	}	5935	}
5964		5936
5965	void	5937	ecb_cold void
5966	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
5967	{	5939	{
5968	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
5969	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
5970	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
5974	/* Truncate the dump stack so TS will return here when done, not	5946	/* Truncate the dump stack so TS will return here when done, not
5975	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
5976	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
5977	}	5949	}
5978		5950
5979	void	5951	ecb_cold void
5980	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
5981	{	5953	{
5982	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
5983	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5984	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5985	/* Pop */	5957	/* Pop */
5986	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5987	}	5959	}
5988		5960
5989	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
5990	pointer	5962	ecb_cold pointer
5991	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
5992	{	5964	{
5993	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
5994		5966
5995	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
6002	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
6003	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
6004	return SCHEME_V->value;	5976	return SCHEME_V->value;
6005	}	5977	}
6006		5978
6007	pointer	5979	ecb_cold pointer
6008	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
6009	{	5981	{
6010	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
6011		5983
6012	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
6024		5996
6025	/* ========== Main ========== */	5997	/* ========== Main ========== */
6026		5998
6027	#if STANDALONE	5999	#if STANDALONE
6028		6000
6029	int	6001	ecb_cold int
6030	main (int argc, char **argv)	6002	main (int argc, char **argv)
6031	{	6003	{
6032	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
6033	scheme ssc;	6005	scheme ssc;
6034	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;
…		…
6040	int isfile = 1;	6012	int isfile = 1;
6041	system ("ps v $PPID");//D	6013	system ("ps v $PPID");//D
6042		6014
6043	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6015	if (argc == 2 && strcmp (argv[1], "-?") == 0)
6044	{	6016	{
6045	xwrstr ("Usage: tinyscheme -?\n");	6017	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6046	xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");	6018	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6047	xwrstr ("followed by\n");	6019	putstr (SCHEME_A_ "followed by\n");
6048	xwrstr (" -1 <file> [<arg1> <arg2> ...]\n");	6020	putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6049	xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n");	6021	putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6050	xwrstr ("assuming that the executable is named tinyscheme.\n");	6022	putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6051	xwrstr ("Use - as filename for stdin.\n");	6023	putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6052	return 1;	6024	return 1;
6053	}	6025	}
6054		6026
6055	if (!scheme_init (SCHEME_A))	6027	if (!scheme_init (SCHEME_A))
6056	{	6028	{
6057	xwrstr ("Could not initialize!\n");	6029	putstr (SCHEME_A_ "Could not initialize!\n");
6058	return 2;	6030	return 2;
6059	}	6031	}
6060		6032
6061	# if USE_PORTS	6033	# if USE_PORTS
6062	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);	6034	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
…		…
6107	fin = open (file_name, O_RDONLY);	6079	fin = open (file_name, O_RDONLY);
6108	#endif	6080	#endif
6109		6081
6110	if (isfile && fin < 0)	6082	if (isfile && fin < 0)
6111	{	6083	{
6112	xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");	6084	putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6113	}	6085	}
6114	else	6086	else
6115	{	6087	{
6116	if (isfile)	6088	if (isfile)
6117	scheme_load_named_file (SCHEME_A_ fin, file_name);	6089	scheme_load_named_file (SCHEME_A_ fin, file_name);
…		…
6121	#if USE_PORTS	6093	#if USE_PORTS
6122	if (!isfile || fin != STDIN_FILENO)	6094	if (!isfile || fin != STDIN_FILENO)
6123	{	6095	{
6124	if (SCHEME_V->retcode != 0)	6096	if (SCHEME_V->retcode != 0)
6125	{	6097	{
6126	xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");	6098	putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6127	}	6099	}
6128		6100
6129	if (isfile)	6101	if (isfile)
6130	close (fin);	6102	close (fin);
6131	}	6103	}

Diff Legend

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