ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.55 by root, Tue Dec 1 03:03:11 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++ = '-';
…		…
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	putnum (SCHEME_P_ long n)	128	putnum (SCHEME_P_ long n)
129	{	129	{
130	char buf[64];	130	char buf[64];
131		131
132	xnum (buf, n);	132	xnum (buf, n);
133	putstr (SCHEME_A_ buf);	133	putstr (SCHEME_A_ buf);
134	}	134	}
135		135
136	static char	136	ecb_cold static char
137	xtoupper (char c)	137	xtoupper (char c)
138	{	138	{
139	if (c >= 'a' && c <= 'z')	139	if (c >= 'a' && c <= 'z')
140	c -= 'a' - 'A';	140	c -= 'a' - 'A';
141		141
142	return c;	142	return c;
143	}	143	}
144		144
145	static char	145	ecb_cold static char
146	xtolower (char c)	146	xtolower (char c)
147	{	147	{
148	if (c >= 'A' && c <= 'Z')	148	if (c >= 'A' && c <= 'Z')
149	c += 'a' - 'A';	149	c += 'a' - 'A';
150		150
151	return c;	151	return c;
152	}	152	}
153		153
154	static int	154	ecb_cold static int
155	xisdigit (char c)	155	xisdigit (char c)
156	{	156	{
157	return c >= '0' && c <= '9';	157	return c >= '0' && c <= '9';
158	}	158	}
159		159
160	#define toupper(c) xtoupper (c)	160	#define toupper(c) xtoupper (c)
161	#define tolower(c) xtolower (c)	161	#define tolower(c) xtolower (c)
162	#define isdigit(c) xisdigit (c)	162	#define isdigit(c) xisdigit (c)
163		163
164	#if USE_IGNORECASE	164	#if USE_IGNORECASE
165	static const char *	165	ecb_cold static const char *
166	xstrlwr (char *s)	166	xstrlwr (char *s)
167	{	167	{
168	const char *p = s;	168	const char *p = s;
169		169
170	while (*s)	170	while (*s)
…		…
193	#endif	193	#endif
194		194
195	enum scheme_types	195	enum scheme_types
196	{	196	{
197	T_INTEGER,	197	T_INTEGER,
		198	T_CHARACTER,
198	T_REAL,	199	T_REAL,
199	T_STRING,	200	T_STRING,
200	T_SYMBOL,	201	T_SYMBOL,
201	T_PROC,	202	T_PROC,
202	T_PAIR, /* also used for free cells */	203	T_PAIR, /* also used for free cells */
203	T_CLOSURE,	204	T_CLOSURE,
		205	T_MACRO,
204	T_CONTINUATION,	206	T_CONTINUATION,
205	T_FOREIGN,	207	T_FOREIGN,
206	T_CHARACTER,
207	T_PORT,	208	T_PORT,
208	T_VECTOR,	209	T_VECTOR,
209	T_MACRO,
210	T_PROMISE,	210	T_PROMISE,
211	T_ENVIRONMENT,	211	T_ENVIRONMENT,
212	/* one more... */	212	/* one more... */
213	T_NUM_SYSTEM_TYPES	213	T_NUM_SYSTEM_TYPES
214	};	214	};
…		…
520	proper list: length	520	proper list: length
521	circular list: -1	521	circular list: -1
522	not even a pair: -2	522	not even a pair: -2
523	dotted list: -2 minus length before dot	523	dotted list: -2 minus length before dot
524	*/	524	*/
525	INTERFACE int	525	ecb_hot INTERFACE int
526	list_length (SCHEME_P_ pointer a)	526	list_length (SCHEME_P_ pointer a)
527	{	527	{
528	int i = 0;	528	int i = 0;
529	pointer slow, fast;	529	pointer slow, fast;
530		530
…		…
636	"gs",	636	"gs",
637	"rs",	637	"rs",
638	"us"	638	"us"
639	};	639	};
640		640
641	static int	641	ecb_cold static int
642	is_ascii_name (const char *name, int *pc)	642	is_ascii_name (const char *name, int *pc)
643	{	643	{
644	int i;	644	int i;
645		645
646	for (i = 0; i < 32; i++)	646	for (i = 0; i < 32; i++)
…		…
883	#endif	883	#endif
884	#endif	884	#endif
885	}	885	}
886		886
887	/* allocate new cell segment */	887	/* allocate new cell segment */
888	static int	888	ecb_cold static int
889	alloc_cellseg (SCHEME_P)	889	alloc_cellseg (SCHEME_P)
890	{	890	{
891	struct cell *newp;	891	struct cell *newp;
892	struct cell *last;	892	struct cell *last;
893	struct cell *p;	893	struct cell *p;
…		…
964	}	964	}
965	}	965	}
966		966
967	/* To retain recent allocs before interpreter knows about them -	967	/* To retain recent allocs before interpreter knows about them -
968	Tehom */	968	Tehom */
969	static void	969	ecb_hot static void
970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
971	{	971	{
972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
973		973
974	set_typeflag (holder, T_PAIR);	974	set_typeflag (holder, T_PAIR);
…		…
976	set_car (holder, recent);	976	set_car (holder, recent);
977	set_cdr (holder, car (S_SINK));	977	set_cdr (holder, car (S_SINK));
978	set_car (S_SINK, holder);	978	set_car (S_SINK, holder);
979	}	979	}
980		980
981	static pointer	981	ecb_hot static pointer
982	get_cell (SCHEME_P_ pointer a, pointer b)	982	get_cell (SCHEME_P_ pointer a, pointer b)
983	{	983	{
984	pointer cell = get_cell_x (SCHEME_A_ a, b);	984	pointer cell = get_cell_x (SCHEME_A_ a, b);
985		985
986	/* 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
…		…
1043	#endif	1043	#endif
1044		1044
1045	/* Medium level cell allocation */	1045	/* Medium level cell allocation */
1046		1046
1047	/* get new cons cell */	1047	/* get new cons cell */
1048	pointer	1048	ecb_hot pointer
1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1050	{	1050	{
1051	pointer x = get_cell (SCHEME_A_ a, b);	1051	pointer x = get_cell (SCHEME_A_ a, b);
1052		1052
1053	set_typeflag (x, T_PAIR);	1053	set_typeflag (x, T_PAIR);
…		…
1059	set_cdr (x, b);	1059	set_cdr (x, b);
1060		1060
1061	return x;	1061	return x;
1062	}	1062	}
1063		1063
1064	static pointer	1064	ecb_cold static pointer
1065	generate_symbol (SCHEME_P_ const char *name)	1065	generate_symbol (SCHEME_P_ const char *name)
1066	{	1066	{
1067	pointer x = mk_string (SCHEME_A_ name);	1067	pointer x = mk_string (SCHEME_A_ name);
1068	setimmutable (x);	1068	setimmutable (x);
1069	set_typeflag (x, T_SYMBOL | T_ATOM);	1069	set_typeflag (x, T_SYMBOL | T_ATOM);
…		…
1084	hash = (hash ^ *p++) * 16777619;	1084	hash = (hash ^ *p++) * 16777619;
1085		1085
1086	return hash % table_size;	1086	return hash % table_size;
1087	}	1087	}
1088		1088
1089	static pointer	1089	ecb_cold static pointer
1090	oblist_initial_value (SCHEME_P)	1090	oblist_initial_value (SCHEME_P)
1091	{	1091	{
1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1093	}	1093	}
1094		1094
1095	/* returns the new symbol */	1095	/* returns the new symbol */
1096	static pointer	1096	ecb_cold static pointer
1097	oblist_add_by_name (SCHEME_P_ const char *name)	1097	oblist_add_by_name (SCHEME_P_ const char *name)
1098	{	1098	{
1099	pointer x = generate_symbol (SCHEME_A_ name);	1099	pointer x = generate_symbol (SCHEME_A_ name);
1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));	1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1101	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)));
1102	return x;	1102	return x;
1103	}	1103	}
1104		1104
1105	ecb_inline pointer	1105	ecb_cold static pointer
1106	oblist_find_by_name (SCHEME_P_ const char *name)	1106	oblist_find_by_name (SCHEME_P_ const char *name)
1107	{	1107	{
1108	int location;	1108	int location;
1109	pointer x;	1109	pointer x;
1110	char *s;	1110	char *s;
…		…
1121	}	1121	}
1122		1122
1123	return NIL;	1123	return NIL;
1124	}	1124	}
1125		1125
1126	static pointer	1126	ecb_cold static pointer
1127	oblist_all_symbols (SCHEME_P)	1127	oblist_all_symbols (SCHEME_P)
1128	{	1128	{
1129	int i;	1129	int i;
1130	pointer x;	1130	pointer x;
1131	pointer ob_list = NIL;	1131	pointer ob_list = NIL;
…		…
1137	return ob_list;	1137	return ob_list;
1138	}	1138	}
1139		1139
1140	#else	1140	#else
1141		1141
1142	static pointer	1142	ecb_cold static pointer
1143	oblist_initial_value (SCHEME_P)	1143	oblist_initial_value (SCHEME_P)
1144	{	1144	{
1145	return NIL;	1145	return NIL;
1146	}	1146	}
1147		1147
1148	ecb_inline pointer	1148	ecb_cold static pointer
1149	oblist_find_by_name (SCHEME_P_ const char *name)	1149	oblist_find_by_name (SCHEME_P_ const char *name)
1150	{	1150	{
1151	pointer x;	1151	pointer x;
1152	char *s;	1152	char *s;
1153		1153
…		…
1162		1162
1163	return NIL;	1163	return NIL;
1164	}	1164	}
1165		1165
1166	/* returns the new symbol */	1166	/* returns the new symbol */
1167	static pointer	1167	ecb_cold static pointer
1168	oblist_add_by_name (SCHEME_P_ const char *name)	1168	oblist_add_by_name (SCHEME_P_ const char *name)
1169	{	1169	{
1170	pointer x = generate_symbol (SCHEME_A_ name);	1170	pointer x = generate_symbol (SCHEME_A_ name);
1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1172	return x;	1172	return x;
1173	}	1173	}
1174		1174
1175	static pointer	1175	ecb_cold static pointer
1176	oblist_all_symbols (SCHEME_P)	1176	oblist_all_symbols (SCHEME_P)
1177	{	1177	{
1178	return SCHEME_V->oblist;	1178	return SCHEME_V->oblist;
1179	}	1179	}
1180		1180
1181	#endif	1181	#endif
1182		1182
1183	#if USE_PORTS	1183	#if USE_PORTS
1184	static pointer	1184	ecb_cold static pointer
1185	mk_port (SCHEME_P_ port *p)	1185	mk_port (SCHEME_P_ port *p)
1186	{	1186	{
1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188		1188
1189	set_typeflag (x, T_PORT | T_ATOM);	1189	set_typeflag (x, T_PORT | T_ATOM);
…		…
1191		1191
1192	return x;	1192	return x;
1193	}	1193	}
1194	#endif	1194	#endif
1195		1195
1196	pointer	1196	ecb_cold pointer
1197	mk_foreign_func (SCHEME_P_ foreign_func f)	1197	mk_foreign_func (SCHEME_P_ foreign_func f)
1198	{	1198	{
1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1200		1200
1201	set_typeflag (x, T_FOREIGN | T_ATOM);	1201	set_typeflag (x, T_FOREIGN | T_ATOM);
…		…
1366	x = oblist_add_by_name (SCHEME_A_ name);	1366	x = oblist_add_by_name (SCHEME_A_ name);
1367		1367
1368	return x;	1368	return x;
1369	}	1369	}
1370		1370
1371	INTERFACE pointer	1371	ecb_cold INTERFACE pointer
1372	gensym (SCHEME_P)	1372	gensym (SCHEME_P)
1373	{	1373	{
1374	pointer x;	1374	pointer x;
1375	char name[40] = "gensym-";	1375	char name[40] = "gensym-";
1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);	1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);
…		…
1383	{	1383	{
1384	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;
1385	}	1385	}
1386		1386
1387	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1388	static pointer	1388	ecb_cold static pointer
1389	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
1390	{	1390	{
1391	char c, *p;	1391	char c, *p;
1392	int has_dec_point = 0;	1392	int has_dec_point = 0;
1393	int has_fp_exp = 0;	1393	int has_fp_exp = 0;
…		…
1464		1464
1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1466	}	1466	}
1467		1467
1468	/* make constant */	1468	/* make constant */
1469	static pointer	1469	ecb_cold static pointer
1470	mk_sharp_const (SCHEME_P_ char *name)	1470	mk_sharp_const (SCHEME_P_ char *name)
1471	{	1471	{
1472	if (!strcmp (name, "t"))	1472	if (!strcmp (name, "t"))
1473	return S_T;	1473	return S_T;
1474	else if (!strcmp (name, "f"))	1474	else if (!strcmp (name, "f"))
1475	return S_F;	1475	return S_F;
1476	else if (*name == '\\') /* #\w (character) */	1476	else if (*name == '\\') /* #\w (character) */
1477	{	1477	{
1478	int c;	1478	int c;
1479		1479
		1480	// TODO: optimise
1480	if (stricmp (name + 1, "space") == 0)	1481	if (stricmp (name + 1, "space") == 0)
1481	c = ' ';	1482	c = ' ';
1482	else if (stricmp (name + 1, "newline") == 0)	1483	else if (stricmp (name + 1, "newline") == 0)
1483	c = '\n';	1484	c = '\n';
1484	else if (stricmp (name + 1, "return") == 0)	1485	else if (stricmp (name + 1, "return") == 0)
1485	c = '\r';	1486	c = '\r';
1486	else if (stricmp (name + 1, "tab") == 0)	1487	else if (stricmp (name + 1, "tab") == 0)
1487	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;
1488	else if (name[1] == 'x' && name[2] != 0)	1499	else if (name[1] == 'x' && name[2] != 0)
1489	{	1500	{
1490	long c1 = strtol (name + 2, 0, 16);	1501	long c1 = strtol (name + 2, 0, 16);
1491		1502
1492	if (0 <= c1 && c1 <= UCHAR_MAX)	1503	if (0 <= c1 && c1 <= UCHAR_MAX)
…		…
1517	return NIL;	1528	return NIL;
1518	}	1529	}
1519	}	1530	}
1520		1531
1521	/* ========== 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	}
1522		1552
1523	/*--	1553	/*--
1524	* 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,
1525	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1526	* for marking.	1556	* for marking.
1527	*	1557	*
1528	* The exception is vectors - vectors are currently marked recursively,	1558	* The exception is vectors - vectors are currently marked recursively,
1529	* 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
1530	* word of context in the vector	1560	* word of context in the vector
1531	*/	1561	*/
1532	static void	1562	ecb_hot static void
1533	mark (pointer a)	1563	mark (pointer a)
1534	{	1564	{
1535	pointer t, q, p;	1565	pointer t, q, p;
1536		1566
1537	t = 0;	1567	t = 0;
…		…
1594	p = q;	1624	p = q;
1595	goto E6;	1625	goto E6;
1596	}	1626	}
1597	}	1627	}
1598		1628
1599	/* garbage collection. parameter a, b is marked. */	1629	ecb_hot static void
1600	static void	1630	gc_free (SCHEME_P)
1601	gc (SCHEME_P_ pointer a, pointer b)
1602	{	1631	{
1603	int i;	1632	int i;
1604
1605	if (SCHEME_V->gc_verbose)
1606	putstr (SCHEME_A_ "gc...");
1607
1608	/* mark system globals */
1609	mark (SCHEME_V->oblist);
1610	mark (SCHEME_V->global_env);
1611
1612	/* mark current registers */
1613	mark (SCHEME_V->args);
1614	mark (SCHEME_V->envir);
1615	mark (SCHEME_V->code);
1616	dump_stack_mark (SCHEME_A);
1617	mark (SCHEME_V->value);
1618	mark (SCHEME_V->inport);
1619	mark (SCHEME_V->save_inport);
1620	mark (SCHEME_V->outport);
1621	mark (SCHEME_V->loadport);
1622
1623	/* Mark recent objects the interpreter doesn't know about yet. */
1624	mark (car (S_SINK));
1625	/* Mark any older stuff above nested C calls */
1626	mark (SCHEME_V->c_nest);
1627
1628	#if USE_INTCACHE
1629	/* mark intcache */
1630	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1631	if (SCHEME_V->intcache[i - INTCACHE_MIN])
1632	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1633	#endif
1634
1635	/* mark variables a, b */
1636	mark (a);
1637	mark (b);
1638
1639	/* garbage collect */
1640	clrmark (NIL);
1641	SCHEME_V->fcells = 0;
1642	SCHEME_V->free_cell = NIL;
1643
1644	if (SCHEME_V->gc_verbose)
1645	putstr (SCHEME_A_ "freeing...");
1646
1647	uint32_t total = 0;	1633	uint32_t total = 0;
1648		1634
1649	/* Here we scan the cells to build the free-list. */	1635	/* Here we scan the cells to build the free-list. */
1650	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)	1636	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1651	{	1637	{
…		…
1680	{	1666	{
1681	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");	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");
1682	}	1668	}
1683	}	1669	}
1684		1670
1685	static void	1671	/* garbage collection. parameter a, b is marked. */
1686	finalize_cell (SCHEME_P_ pointer a)	1672	ecb_cold static void
		1673	gc (SCHEME_P_ pointer a, pointer b)
1687	{	1674	{
1688	/* TODO, fast bitmap check? */	1675	int i;
1689	if (is_string (a) || is_symbol (a))
1690	free (strvalue (a));
1691	else if (is_vector (a))
1692	free (vecvalue (a));
1693	#if USE_PORTS
1694	else if (is_port (a))
1695	{
1696	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1697	port_close (SCHEME_A_ a, port_input | port_output);
1698		1676
1699	free (port (a));	1677	if (SCHEME_V->gc_verbose)
1700	}	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]);
1701	#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);
1702	}	1720	}
1703		1721
1704	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1705		1723
1706	static int	1724	ecb_cold static int
1707	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1708	{	1726	{
1709	#if USE_PORTS	1727	#if USE_PORTS
1710	int fin;	1728	int fin;
1711		1729
…		…
1737	#else	1755	#else
1738	return 1;	1756	return 1;
1739	#endif	1757	#endif
1740	}	1758	}
1741		1759
1742	static void	1760	ecb_cold static void
1743	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1744	{	1762	{
1745	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1746	{	1764	{
1747	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
…		…
1751	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1752	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);
1753	}	1771	}
1754	}	1772	}
1755		1773
1756	static int	1774	ecb_cold static int
1757	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1758	{	1776	{
1759	#if USE_PORTS	1777	#if USE_PORTS
1760	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1761	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
…		…
1764	return 0;	1782	return 0;
1765	#endif	1783	#endif
1766	}	1784	}
1767		1785
1768	#if USE_PORTS	1786	#if USE_PORTS
1769	static port *	1787	ecb_cold static port *
1770	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1771	{	1789	{
1772	int fd;	1790	int fd;
1773	int flags;	1791	int flags;
1774	char *rw;	1792	char *rw;
…		…
1797	# endif	1815	# endif
1798		1816
1799	return pt;	1817	return pt;
1800	}	1818	}
1801		1819
1802	static pointer	1820	ecb_cold static pointer
1803	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1804	{	1822	{
1805	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1806		1824
1807	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1808	return NIL;	1826	return NIL;
1809		1827
1810	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1811	}	1829	}
1812		1830
1813	static port *	1831	ecb_cold static port *
1814	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1815	{	1833	{
1816	port *pt = malloc (sizeof *pt);	1834	port *pt = malloc (sizeof *pt);
1817		1835
1818	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1823	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1824	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1825	return pt;	1843	return pt;
1826	}	1844	}
1827		1845
1828	static pointer	1846	ecb_cold static pointer
1829	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1830	{	1848	{
1831	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1832		1850
1833	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1834	return NIL;	1852	return NIL;
1835		1853
1836	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1837	}	1855	}
1838		1856
1839	static port *	1857	ecb_cold static port *
1840	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)
1841	{	1859	{
1842	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1843		1861
1844	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1850	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1851	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1852	return pt;	1870	return pt;
1853	}	1871	}
1854		1872
1855	static pointer	1873	ecb_cold static pointer
1856	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)
1857	{	1875	{
1858	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);
1859		1877
1860	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1863	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1864	}	1882	}
1865		1883
1866	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1867		1885
1868	static port *	1886	ecb_cold static port *
1869	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1870	{	1888	{
1871	char *start;	1889	char *start;
1872	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1873		1891
…		…
1887	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1888	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1889	return pt;	1907	return pt;
1890	}	1908	}
1891		1909
1892	static pointer	1910	ecb_cold static pointer
1893	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1894	{	1912	{
1895	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1896		1914
1897	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1898	return NIL;	1916	return NIL;
1899		1917
1900	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1901	}	1919	}
1902		1920
1903	static void	1921	ecb_cold static void
1904	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1905	{	1923	{
1906	port *pt = port (p);	1924	port *pt = port (p);
1907		1925
1908	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
…		…
2020	ungot = c;	2038	ungot = c;
2021	#endif	2039	#endif
2022	}	2040	}
2023		2041
2024	#if USE_PORTS	2042	#if USE_PORTS
2025	static int	2043	ecb_cold static int
2026	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2027	{	2045	{
2028	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2029	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;
2030	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2043	else	2061	else
2044	return 0;	2062	return 0;
2045	}	2063	}
2046	#endif	2064	#endif
2047		2065
2048	INTERFACE void	2066	ecb_cold INTERFACE void
2049	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2050	{	2068	{
2051	#if USE_PORTS	2069	#if USE_PORTS
2052	port *pt = port (SCHEME_V->outport);	2070	port *pt = port (SCHEME_V->outport);
2053		2071
…		…
2063	#else	2081	#else
2064	write (pt->rep.stdio.file, s, strlen (s));	2082	write (pt->rep.stdio.file, s, strlen (s));
2065	#endif	2083	#endif
2066	}	2084	}
2067		2085
2068	static void	2086	ecb_cold static void
2069	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2070	{	2088	{
2071	#if USE_PORTS	2089	#if USE_PORTS
2072	port *pt = port (SCHEME_V->outport);	2090	port *pt = port (SCHEME_V->outport);
2073		2091
…		…
2087	#else	2105	#else
2088	write (1, s, len);	2106	write (1, s, len);
2089	#endif	2107	#endif
2090	}	2108	}
2091		2109
2092	INTERFACE void	2110	ecb_cold INTERFACE void
2093	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2094	{	2112	{
2095	#if USE_PORTS	2113	#if USE_PORTS
2096	port *pt = port (SCHEME_V->outport);	2114	port *pt = port (SCHEME_V->outport);
2097		2115
…		…
2113	write (1, &c, 1);	2131	write (1, &c, 1);
2114	#endif	2132	#endif
2115	}	2133	}
2116		2134
2117	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2118	static char *	2136	ecb_cold static char *
2119	readstr_upto (SCHEME_P_ int skip, const char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2120	{	2138	{
2121	char *p = SCHEME_V->strbuff + skip;	2139	char *p = SCHEME_V->strbuff + skip;
2122		2140
2123	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))));
…		…
2132		2150
2133	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2134	}	2152	}
2135		2153
2136	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2137	static pointer	2155	ecb_cold static pointer
2138	readstrexp (SCHEME_P_ char delim)	2156	readstrexp (SCHEME_P_ char delim)
2139	{	2157	{
2140	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2141	int c;	2159	int c;
2142	int c1 = 0;	2160	int c1 = 0;
…		…
2175	case '7':	2193	case '7':
2176	state = st_oct1;	2194	state = st_oct1;
2177	c1 = c - '0';	2195	c1 = c - '0';
2178	break;	2196	break;
2179		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
2180	case 'x':	2206	case 'x':
2181	case 'X':	2207	case 'X':
2182	state = st_x1;	2208	state = st_x1;
2183	c1 = 0;	2209	c1 = 0;
2184	break;
2185
2186	case 'n':
2187	*p++ = '\n';
2188	state = st_ok;
2189	break;
2190
2191	case 't':
2192	*p++ = '\t';
2193	state = st_ok;
2194	break;
2195
2196	case 'r':
2197	*p++ = '\r';
2198	state = st_ok;
2199	break;	2210	break;
2200		2211
2201	default:	2212	default:
2202	*p++ = c;	2213	*p++ = c;
2203	state = st_ok;	2214	state = st_ok;
…		…
2255	}	2266	}
2256	}	2267	}
2257	}	2268	}
2258		2269
2259	/* check c is in chars */	2270	/* check c is in chars */
2260	ecb_inline int	2271	ecb_cold int
2261	is_one_of (const char *s, int c)	2272	is_one_of (const char *s, int c)
2262	{	2273	{
2263	return c == EOF || !!strchr (s, c);	2274	return c == EOF || !!strchr (s, c);
2264	}	2275	}
2265		2276
2266	/* skip white characters */	2277	/* skip white characters */
2267	ecb_inline int	2278	ecb_cold int
2268	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2269	{	2280	{
2270	int c, curr_line = 0;	2281	int c, curr_line = 0;
2271		2282
2272	do	2283	do
…		…
2292	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2293	return 1;	2304	return 1;
2294	}	2305	}
2295		2306
2296	/* get token */	2307	/* get token */
2297	static int	2308	ecb_cold static int
2298	token (SCHEME_P)	2309	token (SCHEME_P)
2299	{	2310	{
2300	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2301		2312
2302	if (c == EOF)	2313	if (c == EOF)
…		…
2400	}	2411	}
2401		2412
2402	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2403	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2404		2415
2405	static void	2416	ecb_cold static void
2406	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2407	{	2418	{
2408	int i;	2419	int i;
2409	unsigned char *s = (unsigned char *) p;	2420	unsigned char *s = (unsigned char *) p;
2410		2421
…		…
2466		2477
2467	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2468	}	2479	}
2469		2480
2470	/* print atoms */	2481	/* print atoms */
2471	static void	2482	ecb_cold static void
2472	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2473	{	2484	{
2474	char *p;	2485	char *p;
2475	int len;	2486	int len;
2476		2487
2477	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2478	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2479	}	2490	}
2480		2491
2481	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2482	static void	2493	ecb_cold static void
2483	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2484	{	2495	{
2485	char *p;	2496	char *p;
2486		2497
2487	if (l == NIL)	2498	if (l == NIL)
…		…
2694	return car (d);	2705	return car (d);
2695		2706
2696	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2697	q = p;	2708	q = p;
2698		2709
2699	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2700	{	2711	{
2701	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2702		2713
2703	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2704	p = cdr (d);	2715	p = cdr (d);
2705	}	2716	}
2706		2717
2707	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2708	return q;	2719	return q;
2709	}	2720	}
2710		2721
2711	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2712	static pointer	2723	ecb_hot static pointer
2713	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2714	{	2725	{
2715	/* a must be checked by gc */	2726	/* a must be checked by gc */
2716	pointer p = NIL;	2727	pointer p = NIL;
2717		2728
…		…
2720		2731
2721	return p;	2732	return p;
2722	}	2733	}
2723		2734
2724	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2725	static pointer	2736	ecb_hot static pointer
2726	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2727	{	2738	{
2728	pointer result = term;	2739	pointer result = term;
2729	pointer p = list;	2740	pointer p = list;
2730		2741
…		…
2738		2749
2739	return result;	2750	return result;
2740	}	2751	}
2741		2752
2742	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2743	static pointer	2754	ecb_hot static pointer
2744	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2745	{	2756	{
2746	pointer result = a;	2757	pointer result = a;
2747	pointer p = b;	2758	pointer p = b;
2748		2759
…		…
2757		2768
2758	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2759	}	2770	}
2760		2771
2761	/* equivalence of atoms */	2772	/* equivalence of atoms */
2762	int	2773	ecb_hot int
2763	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2764	{	2775	{
2765	if (is_string (a))	2776	if (is_string (a))
2766	{	2777	{
2767	if (is_string (b))	2778	if (is_string (b))
…		…
2861	}	2872	}
2862	else	2873	else
2863	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2864	}	2875	}
2865		2876
2866	static pointer	2877	ecb_hot static pointer
2867	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)
2868	{	2879	{
2869	pointer x, y;	2880	pointer x, y;
2870		2881
2871	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
…		…
2892	return NIL;	2903	return NIL;
2893	}	2904	}
2894		2905
2895	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2896		2907
2897	ecb_inline void	2908	static void
2898	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2899	{	2910	{
2900	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2901	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2902	}	2913	}
2903		2914
2904	ecb_inline void	2915	static void
2905	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)
2906	{	2917	{
2907	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2908	}	2919	}
2909		2920
2910	static pointer	2921	ecb_hot static pointer
2911	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)
2912	{	2923	{
2913	pointer x, y;	2924	pointer x, y;
2914		2925
2915	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2929	return NIL;	2940	return NIL;
2930	}	2941	}
2931		2942
2932	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2933		2944
2934	ecb_inline void	2945	static void
2935	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2936	{	2947	{
2937	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2	2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2938	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);
2939	}	2950	}
2940		2951
2941	ecb_inline void	2952	static void
2942	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2943	{	2954	{
2944	set_cdr (slot, value);	2955	set_cdr (slot, value);
2945	}	2956	}
2946		2957
2947	ecb_inline pointer	2958	static pointer
2948	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2949	{	2960	{
2950	return cdr (slot);	2961	return cdr (slot);
2951	}	2962	}
2952		2963
2953	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2954		2965
2955	static int	2966	ecb_cold static int
2956	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2957	{	2968	{
2958	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2959	pointer x;	2970	pointer x;
2960	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3036	pointer code;	3047	pointer code;
3037	};	3048	};
3038		3049
3039	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3040		3051
3041	static void	3052	ecb_hot static void
3042	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)
3043	{	3054	{
3044	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3045	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3046		3057
…		…
3059	next_frame->code = code;	3070	next_frame->code = code;
3060		3071
3061	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3062	}	3073	}
3063		3074
3064	static int	3075	static ecb_hot int
3065	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3066	{	3077	{
3067	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3068	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3069		3080
…		…
3080	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3081		3092
3082	return 0;	3093	return 0;
3083	}	3094	}
3084		3095
3085	ecb_inline void	3096	ecb_cold void
3086	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3087	{	3098	{
3088	/* 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 */
3089	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3090	}	3101	}
3091		3102
3092	ecb_inline void	3103	ecb_cold void
3093	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3094	{	3105	{
3095	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3096	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3097	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3098	}	3109	}
3099		3110
3100	static void	3111	ecb_cold static void
3101	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3102	{	3113	{
3103	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3104	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3105	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3106	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3107	}	3118	}
3108		3119
3109	static void	3120	ecb_cold static void
3110	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3111	{	3122	{
3112	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3113	int i;	3124	int i;
3114		3125
…		…
3120	mark (frame->envir);	3131	mark (frame->envir);
3121	mark (frame->code);	3132	mark (frame->code);
3122	}	3133	}
3123	}	3134	}
3124		3135
3125	static pointer	3136	ecb_cold static pointer
3126	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3127	{	3138	{
3128	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3129	int i;	3140	int i;
3130		3141
…		…
3142	}	3153	}
3143		3154
3144	return cont;	3155	return cont;
3145	}	3156	}
3146		3157
3147	static void	3158	ecb_cold static void
3148	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3149	{	3160	{
3150	int i = 0;	3161	int i = 0;
3151	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3152		3163
…		…
3164	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3165	}	3176	}
3166		3177
3167	#else	3178	#else
3168		3179
3169	ecb_inline void	3180	ecb_cold void
3170	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3171	{	3182	{
3172	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3173	}	3184	}
3174		3185
3175	ecb_inline void	3186	ecb_cold void
3176	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3177	{	3188	{
3178	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3179	}	3190	}
3180		3191
3181	static void	3192	ecb_cold static void
3182	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3183	{	3194	{
3184	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3185	}	3196	}
3186		3197
3187	static int	3198	ecb_hot static int
3188	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3189	{	3200	{
3190	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3191		3202
3192	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
…		…
3202	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3203		3214
3204	return 0;	3215	return 0;
3205	}	3216	}
3206		3217
3207	static void	3218	ecb_hot static void
3208	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)
3209	{	3220	{
3210	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3211	cons (args,	3222	cons (args,
3212	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3213	cons (code,	3224	cons (code,
3214	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3215	}	3226	}
3216		3227
3217	static void	3228	ecb_cold static void
3218	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3219	{	3230	{
3220	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3221	}	3232	}
3222		3233
3223	static pointer	3234	ecb_cold static pointer
3224	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3225	{	3236	{
3226	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3227	}	3238	}
3228		3239
3229	static void	3240	ecb_cold static void
3230	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3231	{	3242	{
3232	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3233	}	3244	}
3234		3245
…		…
3292	break;	3303	break;
3293	}	3304	}
3294	}	3305	}
3295	#endif	3306	#endif
3296		3307
3297	static int	3308	/* syntax, eval, core, ... */
		3309	ecb_hot static int
3298	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3299	{	3311	{
3300	pointer args = SCHEME_V->args;	3312	pointer args = SCHEME_V->args;
3301	pointer x, y;	3313	pointer x, y;
3302		3314
…		…
3988	}	4000	}
3989		4001
3990	if (USE_ERROR_CHECKING) abort ();	4002	if (USE_ERROR_CHECKING) abort ();
3991	}	4003	}
3992		4004
3993	static int	4005	/* math, cxr */
		4006	ecb_hot static int
3994	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3995	{	4008	{
3996	pointer args = SCHEME_V->args;	4009	pointer args = SCHEME_V->args;
3997	pointer x = car (args);	4010	pointer x = car (args);
3998	num v;	4011	num v;
…		…
4011	Error_1 ("inexact->exact: not integral:", x);	4024	Error_1 ("inexact->exact: not integral:", x);
4012	}	4025	}
4013		4026
4014	s_return (x);	4027	s_return (x);
4015		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))));
4016	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))));
4017	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))
4018	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));	4037	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4019	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))));
4020	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))));
…		…
4026	s_return (mk_real (SCHEME_A_	4045	s_return (mk_real (SCHEME_A_
4027	cdr (args) == NIL	4046	cdr (args) == NIL
4028	? atan (rvalue (x))	4047	? atan (rvalue (x))
4029	: atan2 (rvalue (x), rvalue (cadr (args)))));	4048	: atan2 (rvalue (x), rvalue (cadr (args)))));
4030		4049
4031	case OP_SQRT:
4032	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4033
4034	case OP_EXPT:	4050	case OP_EXPT:
4035	{	4051	{
4036	RVALUE result;	4052	RVALUE result;
4037	int real_result = 1;	4053	int real_result = 1;
4038	pointer y = cadr (args);	4054	pointer y = cadr (args);
…		…
4060	if (real_result)	4076	if (real_result)
4061	s_return (mk_real (SCHEME_A_ result));	4077	s_return (mk_real (SCHEME_A_ result));
4062	else	4078	else
4063	s_return (mk_integer (SCHEME_A_ result));	4079	s_return (mk_integer (SCHEME_A_ result));
4064	}	4080	}
4065
4066	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4067	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4068	case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4069	case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4070	#endif	4081	#endif
4071		4082
4072	case OP_ADD: /* + */	4083	case OP_ADD: /* + */
4073	v = num_zero;	4084	v = num_zero;
4074		4085
…		…
4376	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4387	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4377		4388
4378	s_return (newstr);	4389	s_return (newstr);
4379	}	4390	}
4380		4391
4381	case OP_SUBSTR: /* substring */	4392	case OP_STRING_COPY: /* substring/string-copy */
4382	{	4393	{
4383	char *str = strvalue (x);	4394	char *str = strvalue (x);
4384	int index0 = ivalue_unchecked (cadr (args));	4395	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4385	int index1;	4396	int index1;
4386	int len;	4397	int len;
4387		4398
4388	if (index0 > strlength (x))	4399	if (index0 > strlength (x))
4389	Error_1 ("substring: start out of bounds:", cadr (args));	4400	Error_1 ("string->copy: start out of bounds:", cadr (args));
4390		4401
4391	if (cddr (args) != NIL)	4402	if (cddr (args) != NIL)
4392	{	4403	{
4393	index1 = ivalue_unchecked (caddr (args));	4404	index1 = ivalue_unchecked (caddr (args));
4394		4405
4395	if (index1 > strlength (x) || index1 < index0)	4406	if (index1 > strlength (x) || index1 < index0)
4396	Error_1 ("substring: end out of bounds:", caddr (args));	4407	Error_1 ("string->copy: end out of bounds:", caddr (args));
4397	}	4408	}
4398	else	4409	else
4399	index1 = strlength (x);	4410	index1 = strlength (x);
4400		4411
4401	len = index1 - index0;	4412	len = index1 - index0;
4402	x = mk_empty_string (SCHEME_A_ len, ' ');	4413	x = mk_counted_string (SCHEME_A_ str + index0, len);
4403	memcpy (strvalue (x), str + index0, len);
4404	strvalue (x)[len] = 0;
4405		4414
4406	s_return (x);	4415	s_return (x);
4407	}	4416	}
4408		4417
4409	case OP_VECTOR: /* vector */	4418	case OP_VECTOR: /* vector */
…		…
4483	}	4492	}
4484		4493
4485	if (USE_ERROR_CHECKING) abort ();	4494	if (USE_ERROR_CHECKING) abort ();
4486	}	4495	}
4487		4496
4488	static int	4497	/* relational ops */
		4498	ecb_hot static int
4489	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4499	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4490	{	4500	{
4491	pointer x = SCHEME_V->args;	4501	pointer x = SCHEME_V->args;
4492		4502
4493	for (;;)	4503	for (;;)
…		…
4514	}	4524	}
4515		4525
4516	s_return (S_T);	4526	s_return (S_T);
4517	}	4527	}
4518		4528
4519	static int	4529	/* predicates */
		4530	ecb_hot static int
4520	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4531	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4521	{	4532	{
4522	pointer args = SCHEME_V->args;	4533	pointer args = SCHEME_V->args;
4523	pointer a = car (args);	4534	pointer a = car (args);
4524	pointer d = cdr (args);	4535	pointer d = cdr (args);
…		…
4571	}	4582	}
4572		4583
4573	s_retbool (r);	4584	s_retbool (r);
4574	}	4585	}
4575		4586
4576	static int	4587	/* promises, list ops, ports */
		4588	ecb_hot static int
4577	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4589	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4578	{	4590	{
4579	pointer args = SCHEME_V->args;	4591	pointer args = SCHEME_V->args;
4580	pointer a = car (args);	4592	pointer a = car (args);
4581	pointer x, y;	4593	pointer x, y;
…		…
4598	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4610	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4599	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);	4611	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4600	s_return (SCHEME_V->value);	4612	s_return (SCHEME_V->value);
4601		4613
4602	#if USE_PORTS	4614	#if USE_PORTS
		4615
		4616	case OP_EOF_OBJECT: /* eof-object */
		4617	s_return (S_EOF);
4603		4618
4604	case OP_WRITE: /* write */	4619	case OP_WRITE: /* write */
4605	case OP_DISPLAY: /* display */	4620	case OP_DISPLAY: /* display */
4606	case OP_WRITE_CHAR: /* write-char */	4621	case OP_WRITE_CHAR: /* write-char */
4607	if (is_pair (cdr (SCHEME_V->args)))	4622	if (is_pair (cdr (SCHEME_V->args)))
…		…
4880	}	4895	}
4881		4896
4882	if (USE_ERROR_CHECKING) abort ();	4897	if (USE_ERROR_CHECKING) abort ();
4883	}	4898	}
4884		4899
4885	static int	4900	/* reading */
		4901	ecb_cold static int
4886	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4887	{	4903	{
4888	pointer args = SCHEME_V->args;	4904	pointer args = SCHEME_V->args;
4889	pointer x;	4905	pointer x;
4890		4906
…		…
5232	}	5248	}
5233		5249
5234	if (USE_ERROR_CHECKING) abort ();	5250	if (USE_ERROR_CHECKING) abort ();
5235	}	5251	}
5236		5252
5237	static int	5253	/* list ops */
		5254	ecb_hot static int
5238	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239	{	5256	{
5240	pointer args = SCHEME_V->args;	5257	pointer args = SCHEME_V->args;
5241	pointer a = car (args);	5258	pointer a = car (args);
5242	pointer x, y;	5259	pointer x, y;
…		…
5300		5317
5301	/* 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 */
5302	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5303		5320
5304	typedef int (*test_predicate)(pointer);	5321	typedef int (*test_predicate)(pointer);
5305	static int	5322
		5323	ecb_hot static int
5306	tst_any (pointer p)	5324	tst_any (pointer p)
5307	{	5325	{
5308	return 1;	5326	return 1;
5309	}	5327	}
5310		5328
5311	static int	5329	ecb_hot static int
5312	tst_inonneg (pointer p)	5330	tst_inonneg (pointer p)
5313	{	5331	{
5314	return is_integer (p) && ivalue_unchecked (p) >= 0;	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
5315	}	5333	}
5316		5334
5317	static int	5335	ecb_hot static int
5318	tst_is_list (SCHEME_P_ pointer p)	5336	tst_is_list (SCHEME_P_ pointer p)
5319	{	5337	{
5320	return p == NIL || is_pair (p);	5338	return p == NIL || is_pair (p);
5321	}	5339	}
5322		5340
…		…
5365	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5366	#include "opdefines.h"	5384	#include "opdefines.h"
5367	#undef OP_DEF	5385	#undef OP_DEF
5368	;	5386	;
5369		5387
5370	static const char *	5388	ecb_cold static const char *
5371	opname (int idx)	5389	opname (int idx)
5372	{	5390	{
5373	const char *name = opnames;	5391	const char *name = opnames;
5374		5392
5375	/* 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? */
…		…
5377	name += strlen (name) + 1;	5395	name += strlen (name) + 1;
5378		5396
5379	return *name ? name : "ILLEGAL";	5397	return *name ? name : "ILLEGAL";
5380	}	5398	}
5381		5399
5382	static const char *	5400	ecb_cold static const char *
5383	procname (pointer x)	5401	procname (pointer x)
5384	{	5402	{
5385	return opname (procnum (x));	5403	return opname (procnum (x));
5386	}	5404	}
5387		5405
…		…
5407	#undef OP_DEF	5425	#undef OP_DEF
5408	{0}	5426	{0}
5409	};	5427	};
5410		5428
5411	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5412	static void ecb_hot	5430	ecb_hot static void
5413	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5414	{	5432	{
5415	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5416		5434
5417	for (;;)	5435	for (;;)
…		…
5508	}	5526	}
5509	}	5527	}
5510		5528
5511	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5512		5530
5513	static void	5531	ecb_cold static void
5514	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5515	{	5533	{
5516	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5517	set_typeflag (x, typeflag (x) | T_SYNTAX);	5535	set_typeflag (x, typeflag (x) | T_SYNTAX);
5518	}	5536	}
5519		5537
5520	static void	5538	ecb_cold static void
5521	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5522	{	5540	{
5523	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5524	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5525	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5533	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5534	return y;	5552	return y;
5535	}	5553	}
5536		5554
5537	/* 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! */
5538	static int	5556	ecb_hot static int
5539	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5540	{	5558	{
5541	const char *s = strvalue (p);	5559	const char *s = strvalue (p);
5542		5560
5543	switch (strlength (p))	5561	switch (strlength (p))
…		…
5728		5746
5729	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5730	}	5748	}
5731		5749
5732	#if USE_PORTS	5750	#if USE_PORTS
5733	void	5751	ecb_cold void
5734	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5735	{	5753	{
5736	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5737	}	5755	}
5738		5756
5739	void	5757	ecb_cold void
5740	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)
5741	{	5759	{
5742	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);
5743	}	5761	}
5744		5762
5745	void	5763	ecb_cold void
5746	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5747	{	5765	{
5748	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5749	}	5767	}
5750		5768
5751	void	5769	ecb_cold void
5752	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)
5753	{	5771	{
5754	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);
5755	}	5773	}
5756	#endif	5774	#endif
5757		5775
5758	void	5776	ecb_cold void
5759	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5760	{	5778	{
5761	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5762	}	5780	}
5763		5781
…		…
5811	}	5829	}
5812	}	5830	}
5813	#endif	5831	#endif
5814	}	5832	}
5815		5833
5816	void	5834	ecb_cold void
5817	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5818	{	5836	{
5819	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5820	}	5838	}
5821		5839
5822	void	5840	ecb_cold void
5823	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5824	{	5842	{
5825	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5826	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5827	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5854		5872
5855	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5856	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5857	}	5875	}
5858		5876
5859	void	5877	ecb_cold void
5860	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5861	{	5879	{
5862	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5863	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5864	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
…		…
5878		5896
5879	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5880	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5881	}	5899	}
5882		5900
5883	void	5901	ecb_cold void
5884	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5885	{	5903	{
5886	pointer x;	5904	pointer x;
5887		5905
5888	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5893	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5894	}	5912	}
5895		5913
5896	#if !STANDALONE	5914	#if !STANDALONE
5897		5915
5898	void	5916	ecb_cold void
5899	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5900	{	5918	{
5901	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));
5902	}	5920	}
5903		5921
5904	void	5922	ecb_cold void
5905	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)
5906	{	5924	{
5907	int i;	5925	int i;
5908		5926
5909	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
5910	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
5911	}	5929	}
5912		5930
5913	pointer	5931	ecb_cold pointer
5914	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
5915	{	5933	{
5916	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));
5917	}	5935	}
5918		5936
5919	void	5937	ecb_cold void
5920	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
5921	{	5939	{
5922	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
5923	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
5924	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
5928	/* 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
5929	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
5930	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
5931	}	5949	}
5932		5950
5933	void	5951	ecb_cold void
5934	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
5935	{	5953	{
5936	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
5937	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5938	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5939	/* Pop */	5957	/* Pop */
5940	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5941	}	5959	}
5942		5960
5943	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
5944	pointer	5962	ecb_cold pointer
5945	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
5946	{	5964	{
5947	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
5948		5966
5949	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
5956	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
5957	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
5958	return SCHEME_V->value;	5976	return SCHEME_V->value;
5959	}	5977	}
5960		5978
5961	pointer	5979	ecb_cold pointer
5962	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
5963	{	5981	{
5964	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
5965		5983
5966	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
5978		5996
5979	/* ========== Main ========== */	5997	/* ========== Main ========== */
5980		5998
5981	#if STANDALONE	5999	#if STANDALONE
5982		6000
5983	int	6001	ecb_cold int
5984	main (int argc, char **argv)	6002	main (int argc, char **argv)
5985	{	6003	{
5986	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
5987	scheme ssc;	6005	scheme ssc;
5988	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;

Diff Legend

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