ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.53 by root, Tue Dec 1 02:21:49 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	};
…		…
250	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);
251	static num num_intdiv (num a, num b);	251	static num num_intdiv (num a, num b);
252	static num num_rem (num a, num b);	252	static num num_rem (num a, num b);
253	static num num_mod (num a, num b);	253	static num num_mod (num a, num b);
254		254
255	#if USE_MATH
256	static double round_per_R5RS (double x);
257	#endif
258	static int is_zero_rvalue (RVALUE x);	255	static int is_zero_rvalue (RVALUE x);
259		256
260	static num num_zero;	257	static num num_zero;
261	static num num_one;	258	static num num_one;
262		259
…		…
523	proper list: length	520	proper list: length
524	circular list: -1	521	circular list: -1
525	not even a pair: -2	522	not even a pair: -2
526	dotted list: -2 minus length before dot	523	dotted list: -2 minus length before dot
527	*/	524	*/
528	INTERFACE int	525	ecb_hot INTERFACE int
529	list_length (SCHEME_P_ pointer a)	526	list_length (SCHEME_P_ pointer a)
530	{	527	{
531	int i = 0;	528	int i = 0;
532	pointer slow, fast;	529	pointer slow, fast;
533		530
…		…
639	"gs",	636	"gs",
640	"rs",	637	"rs",
641	"us"	638	"us"
642	};	639	};
643		640
644	static int	641	ecb_cold static int
645	is_ascii_name (const char *name, int *pc)	642	is_ascii_name (const char *name, int *pc)
646	{	643	{
647	int i;	644	int i;
648		645
649	for (i = 0; i < 32; i++)	646	for (i = 0; i < 32; i++)
…		…
872	}	869	}
873		870
874	return ret;	871	return ret;
875	}	872	}
876		873
877	#if USE_MATH
878
879	/* Round to nearest. Round to even if midway */
880	static double
881	round_per_R5RS (double x)
882	{
883	double fl = floor (x);
884	double ce = ceil (x);
885	double dfl = x - fl;
886	double dce = ce - x;
887
888	if (dfl > dce)
889	return ce;
890	else if (dfl < dce)
891	return fl;
892	else
893	{
894	if (fmod (fl, 2) == 0) /* I imagine this holds */
895	return fl;
896	else
897	return ce;
898	}
899	}
900	#endif
901
902	static int	874	static int
903	is_zero_rvalue (RVALUE x)	875	is_zero_rvalue (RVALUE x)
904	{	876	{
905	return x == 0;	877	return x == 0;
906	#if 0	878	#if 0
…		…
911	#endif	883	#endif
912	#endif	884	#endif
913	}	885	}
914		886
915	/* allocate new cell segment */	887	/* allocate new cell segment */
916	static int	888	ecb_cold static int
917	alloc_cellseg (SCHEME_P)	889	alloc_cellseg (SCHEME_P)
918	{	890	{
919	struct cell *newp;	891	struct cell *newp;
920	struct cell *last;	892	struct cell *last;
921	struct cell *p;	893	struct cell *p;
…		…
992	}	964	}
993	}	965	}
994		966
995	/* To retain recent allocs before interpreter knows about them -	967	/* To retain recent allocs before interpreter knows about them -
996	Tehom */	968	Tehom */
997	static void	969	ecb_hot static void
998	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
999	{	971	{
1000	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1001		973
1002	set_typeflag (holder, T_PAIR);	974	set_typeflag (holder, T_PAIR);
…		…
1004	set_car (holder, recent);	976	set_car (holder, recent);
1005	set_cdr (holder, car (S_SINK));	977	set_cdr (holder, car (S_SINK));
1006	set_car (S_SINK, holder);	978	set_car (S_SINK, holder);
1007	}	979	}
1008		980
1009	static pointer	981	ecb_hot static pointer
1010	get_cell (SCHEME_P_ pointer a, pointer b)	982	get_cell (SCHEME_P_ pointer a, pointer b)
1011	{	983	{
1012	pointer cell = get_cell_x (SCHEME_A_ a, b);	984	pointer cell = get_cell_x (SCHEME_A_ a, b);
1013		985
1014	/* 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
…		…
1071	#endif	1043	#endif
1072		1044
1073	/* Medium level cell allocation */	1045	/* Medium level cell allocation */
1074		1046
1075	/* get new cons cell */	1047	/* get new cons cell */
1076	pointer	1048	ecb_hot pointer
1077	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1078	{	1050	{
1079	pointer x = get_cell (SCHEME_A_ a, b);	1051	pointer x = get_cell (SCHEME_A_ a, b);
1080		1052
1081	set_typeflag (x, T_PAIR);	1053	set_typeflag (x, T_PAIR);
…		…
1087	set_cdr (x, b);	1059	set_cdr (x, b);
1088		1060
1089	return x;	1061	return x;
1090	}	1062	}
1091		1063
1092	static pointer	1064	ecb_cold static pointer
1093	generate_symbol (SCHEME_P_ const char *name)	1065	generate_symbol (SCHEME_P_ const char *name)
1094	{	1066	{
1095	pointer x = mk_string (SCHEME_A_ name);	1067	pointer x = mk_string (SCHEME_A_ name);
1096	setimmutable (x);	1068	setimmutable (x);
1097	set_typeflag (x, T_SYMBOL | T_ATOM);	1069	set_typeflag (x, T_SYMBOL | T_ATOM);
…		…
1112	hash = (hash ^ *p++) * 16777619;	1084	hash = (hash ^ *p++) * 16777619;
1113		1085
1114	return hash % table_size;	1086	return hash % table_size;
1115	}	1087	}
1116		1088
1117	static pointer	1089	ecb_cold static pointer
1118	oblist_initial_value (SCHEME_P)	1090	oblist_initial_value (SCHEME_P)
1119	{	1091	{
1120	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1121	}	1093	}
1122		1094
1123	/* returns the new symbol */	1095	/* returns the new symbol */
1124	static pointer	1096	ecb_cold static pointer
1125	oblist_add_by_name (SCHEME_P_ const char *name)	1097	oblist_add_by_name (SCHEME_P_ const char *name)
1126	{	1098	{
1127	pointer x = generate_symbol (SCHEME_A_ name);	1099	pointer x = generate_symbol (SCHEME_A_ name);
1128	int location = hash_fn (name, veclength (SCHEME_V->oblist));	1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1129	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)));
1130	return x;	1102	return x;
1131	}	1103	}
1132		1104
1133	ecb_inline pointer	1105	ecb_cold static pointer
1134	oblist_find_by_name (SCHEME_P_ const char *name)	1106	oblist_find_by_name (SCHEME_P_ const char *name)
1135	{	1107	{
1136	int location;	1108	int location;
1137	pointer x;	1109	pointer x;
1138	char *s;	1110	char *s;
…		…
1149	}	1121	}
1150		1122
1151	return NIL;	1123	return NIL;
1152	}	1124	}
1153		1125
1154	static pointer	1126	ecb_cold static pointer
1155	oblist_all_symbols (SCHEME_P)	1127	oblist_all_symbols (SCHEME_P)
1156	{	1128	{
1157	int i;	1129	int i;
1158	pointer x;	1130	pointer x;
1159	pointer ob_list = NIL;	1131	pointer ob_list = NIL;
…		…
1165	return ob_list;	1137	return ob_list;
1166	}	1138	}
1167		1139
1168	#else	1140	#else
1169		1141
1170	static pointer	1142	ecb_cold static pointer
1171	oblist_initial_value (SCHEME_P)	1143	oblist_initial_value (SCHEME_P)
1172	{	1144	{
1173	return NIL;	1145	return NIL;
1174	}	1146	}
1175		1147
1176	ecb_inline pointer	1148	ecb_cold static pointer
1177	oblist_find_by_name (SCHEME_P_ const char *name)	1149	oblist_find_by_name (SCHEME_P_ const char *name)
1178	{	1150	{
1179	pointer x;	1151	pointer x;
1180	char *s;	1152	char *s;
1181		1153
…		…
1190		1162
1191	return NIL;	1163	return NIL;
1192	}	1164	}
1193		1165
1194	/* returns the new symbol */	1166	/* returns the new symbol */
1195	static pointer	1167	ecb_cold static pointer
1196	oblist_add_by_name (SCHEME_P_ const char *name)	1168	oblist_add_by_name (SCHEME_P_ const char *name)
1197	{	1169	{
1198	pointer x = generate_symbol (SCHEME_A_ name);	1170	pointer x = generate_symbol (SCHEME_A_ name);
1199	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1200	return x;	1172	return x;
1201	}	1173	}
1202		1174
1203	static pointer	1175	ecb_cold static pointer
1204	oblist_all_symbols (SCHEME_P)	1176	oblist_all_symbols (SCHEME_P)
1205	{	1177	{
1206	return SCHEME_V->oblist;	1178	return SCHEME_V->oblist;
1207	}	1179	}
1208		1180
1209	#endif	1181	#endif
1210		1182
1211	#if USE_PORTS	1183	#if USE_PORTS
1212	static pointer	1184	ecb_cold static pointer
1213	mk_port (SCHEME_P_ port *p)	1185	mk_port (SCHEME_P_ port *p)
1214	{	1186	{
1215	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1216		1188
1217	set_typeflag (x, T_PORT | T_ATOM);	1189	set_typeflag (x, T_PORT | T_ATOM);
…		…
1219		1191
1220	return x;	1192	return x;
1221	}	1193	}
1222	#endif	1194	#endif
1223		1195
1224	pointer	1196	ecb_cold pointer
1225	mk_foreign_func (SCHEME_P_ foreign_func f)	1197	mk_foreign_func (SCHEME_P_ foreign_func f)
1226	{	1198	{
1227	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1228		1200
1229	set_typeflag (x, T_FOREIGN | T_ATOM);	1201	set_typeflag (x, T_FOREIGN | T_ATOM);
…		…
1394	x = oblist_add_by_name (SCHEME_A_ name);	1366	x = oblist_add_by_name (SCHEME_A_ name);
1395		1367
1396	return x;	1368	return x;
1397	}	1369	}
1398		1370
1399	INTERFACE pointer	1371	ecb_cold INTERFACE pointer
1400	gensym (SCHEME_P)	1372	gensym (SCHEME_P)
1401	{	1373	{
1402	pointer x;	1374	pointer x;
1403	char name[40] = "gensym-";	1375	char name[40] = "gensym-";
1404	xnum (name + 7, ++SCHEME_V->gensym_cnt);	1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);
…		…
1411	{	1383	{
1412	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;
1413	}	1385	}
1414		1386
1415	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1416	static pointer	1388	ecb_cold static pointer
1417	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
1418	{	1390	{
1419	char c, *p;	1391	char c, *p;
1420	int has_dec_point = 0;	1392	int has_dec_point = 0;
1421	int has_fp_exp = 0;	1393	int has_fp_exp = 0;
…		…
1492		1464
1493	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1494	}	1466	}
1495		1467
1496	/* make constant */	1468	/* make constant */
1497	static pointer	1469	ecb_cold static pointer
1498	mk_sharp_const (SCHEME_P_ char *name)	1470	mk_sharp_const (SCHEME_P_ char *name)
1499	{	1471	{
1500	if (!strcmp (name, "t"))	1472	if (!strcmp (name, "t"))
1501	return S_T;	1473	return S_T;
1502	else if (!strcmp (name, "f"))	1474	else if (!strcmp (name, "f"))
1503	return S_F;	1475	return S_F;
1504	else if (*name == '\\') /* #\w (character) */	1476	else if (*name == '\\') /* #\w (character) */
1505	{	1477	{
1506	int c;	1478	int c;
1507		1479
		1480	// TODO: optimise
1508	if (stricmp (name + 1, "space") == 0)	1481	if (stricmp (name + 1, "space") == 0)
1509	c = ' ';	1482	c = ' ';
1510	else if (stricmp (name + 1, "newline") == 0)	1483	else if (stricmp (name + 1, "newline") == 0)
1511	c = '\n';	1484	c = '\n';
1512	else if (stricmp (name + 1, "return") == 0)	1485	else if (stricmp (name + 1, "return") == 0)
1513	c = '\r';	1486	c = '\r';
1514	else if (stricmp (name + 1, "tab") == 0)	1487	else if (stricmp (name + 1, "tab") == 0)
1515	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;
1516	else if (name[1] == 'x' && name[2] != 0)	1499	else if (name[1] == 'x' && name[2] != 0)
1517	{	1500	{
1518	long c1 = strtol (name + 2, 0, 16);	1501	long c1 = strtol (name + 2, 0, 16);
1519		1502
1520	if (0 <= c1 && c1 <= UCHAR_MAX)	1503	if (0 <= c1 && c1 <= UCHAR_MAX)
…		…
1545	return NIL;	1528	return NIL;
1546	}	1529	}
1547	}	1530	}
1548		1531
1549	/* ========== 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	}
1550		1552
1551	/*--	1553	/*--
1552	* 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,
1553	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1554	* for marking.	1556	* for marking.
1555	*	1557	*
1556	* The exception is vectors - vectors are currently marked recursively,	1558	* The exception is vectors - vectors are currently marked recursively,
1557	* 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
1558	* word of context in the vector	1560	* word of context in the vector
1559	*/	1561	*/
1560	static void	1562	ecb_hot static void
1561	mark (pointer a)	1563	mark (pointer a)
1562	{	1564	{
1563	pointer t, q, p;	1565	pointer t, q, p;
1564		1566
1565	t = 0;	1567	t = 0;
…		…
1622	p = q;	1624	p = q;
1623	goto E6;	1625	goto E6;
1624	}	1626	}
1625	}	1627	}
1626		1628
1627	/* garbage collection. parameter a, b is marked. */	1629	ecb_hot static void
1628	static void	1630	gc_free (SCHEME_P)
1629	gc (SCHEME_P_ pointer a, pointer b)
1630	{	1631	{
1631	int i;	1632	int i;
1632
1633	if (SCHEME_V->gc_verbose)
1634	putstr (SCHEME_A_ "gc...");
1635
1636	/* mark system globals */
1637	mark (SCHEME_V->oblist);
1638	mark (SCHEME_V->global_env);
1639
1640	/* mark current registers */
1641	mark (SCHEME_V->args);
1642	mark (SCHEME_V->envir);
1643	mark (SCHEME_V->code);
1644	dump_stack_mark (SCHEME_A);
1645	mark (SCHEME_V->value);
1646	mark (SCHEME_V->inport);
1647	mark (SCHEME_V->save_inport);
1648	mark (SCHEME_V->outport);
1649	mark (SCHEME_V->loadport);
1650
1651	/* Mark recent objects the interpreter doesn't know about yet. */
1652	mark (car (S_SINK));
1653	/* Mark any older stuff above nested C calls */
1654	mark (SCHEME_V->c_nest);
1655
1656	#if USE_INTCACHE
1657	/* mark intcache */
1658	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1659	if (SCHEME_V->intcache[i - INTCACHE_MIN])
1660	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1661	#endif
1662
1663	/* mark variables a, b */
1664	mark (a);
1665	mark (b);
1666
1667	/* garbage collect */
1668	clrmark (NIL);
1669	SCHEME_V->fcells = 0;
1670	SCHEME_V->free_cell = NIL;
1671
1672	if (SCHEME_V->gc_verbose)
1673	putstr (SCHEME_A_ "freeing...");
1674
1675	uint32_t total = 0;	1633	uint32_t total = 0;
1676		1634
1677	/* Here we scan the cells to build the free-list. */	1635	/* Here we scan the cells to build the free-list. */
1678	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)	1636	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1679	{	1637	{
…		…
1708	{	1666	{
1709	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");
1710	}	1668	}
1711	}	1669	}
1712		1670
1713	static void	1671	/* garbage collection. parameter a, b is marked. */
1714	finalize_cell (SCHEME_P_ pointer a)	1672	ecb_cold static void
		1673	gc (SCHEME_P_ pointer a, pointer b)
1715	{	1674	{
1716	/* TODO, fast bitmap check? */	1675	int i;
1717	if (is_string (a) || is_symbol (a))
1718	free (strvalue (a));
1719	else if (is_vector (a))
1720	free (vecvalue (a));
1721	#if USE_PORTS
1722	else if (is_port (a))
1723	{
1724	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1725	port_close (SCHEME_A_ a, port_input | port_output);
1726		1676
1727	free (port (a));	1677	if (SCHEME_V->gc_verbose)
1728	}	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]);
1729	#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);
1730	}	1720	}
1731		1721
1732	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1733		1723
1734	static int	1724	ecb_cold static int
1735	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1736	{	1726	{
1737	#if USE_PORTS	1727	#if USE_PORTS
1738	int fin;	1728	int fin;
1739		1729
…		…
1765	#else	1755	#else
1766	return 1;	1756	return 1;
1767	#endif	1757	#endif
1768	}	1758	}
1769		1759
1770	static void	1760	ecb_cold static void
1771	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1772	{	1762	{
1773	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1774	{	1764	{
1775	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
…		…
1779	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1780	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);
1781	}	1771	}
1782	}	1772	}
1783		1773
1784	static int	1774	ecb_cold static int
1785	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1786	{	1776	{
1787	#if USE_PORTS	1777	#if USE_PORTS
1788	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1789	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
…		…
1792	return 0;	1782	return 0;
1793	#endif	1783	#endif
1794	}	1784	}
1795		1785
1796	#if USE_PORTS	1786	#if USE_PORTS
1797	static port *	1787	ecb_cold static port *
1798	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1799	{	1789	{
1800	int fd;	1790	int fd;
1801	int flags;	1791	int flags;
1802	char *rw;	1792	char *rw;
…		…
1825	# endif	1815	# endif
1826		1816
1827	return pt;	1817	return pt;
1828	}	1818	}
1829		1819
1830	static pointer	1820	ecb_cold static pointer
1831	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1832	{	1822	{
1833	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1834		1824
1835	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1836	return NIL;	1826	return NIL;
1837		1827
1838	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1839	}	1829	}
1840		1830
1841	static port *	1831	ecb_cold static port *
1842	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1843	{	1833	{
1844	port *pt = malloc (sizeof *pt);	1834	port *pt = malloc (sizeof *pt);
1845		1835
1846	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1851	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1852	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1853	return pt;	1843	return pt;
1854	}	1844	}
1855		1845
1856	static pointer	1846	ecb_cold static pointer
1857	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1858	{	1848	{
1859	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1860		1850
1861	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1862	return NIL;	1852	return NIL;
1863		1853
1864	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1865	}	1855	}
1866		1856
1867	static port *	1857	ecb_cold static port *
1868	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)
1869	{	1859	{
1870	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1871		1861
1872	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1878	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1879	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1880	return pt;	1870	return pt;
1881	}	1871	}
1882		1872
1883	static pointer	1873	ecb_cold static pointer
1884	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)
1885	{	1875	{
1886	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);
1887		1877
1888	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1891	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1892	}	1882	}
1893		1883
1894	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1895		1885
1896	static port *	1886	ecb_cold static port *
1897	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1898	{	1888	{
1899	char *start;	1889	char *start;
1900	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1901		1891
…		…
1915	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1916	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1917	return pt;	1907	return pt;
1918	}	1908	}
1919		1909
1920	static pointer	1910	ecb_cold static pointer
1921	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1922	{	1912	{
1923	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1924		1914
1925	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1926	return NIL;	1916	return NIL;
1927		1917
1928	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1929	}	1919	}
1930		1920
1931	static void	1921	ecb_cold static void
1932	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1933	{	1923	{
1934	port *pt = port (p);	1924	port *pt = port (p);
1935		1925
1936	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
…		…
2048	ungot = c;	2038	ungot = c;
2049	#endif	2039	#endif
2050	}	2040	}
2051		2041
2052	#if USE_PORTS	2042	#if USE_PORTS
2053	static int	2043	ecb_cold static int
2054	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2055	{	2045	{
2056	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2057	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;
2058	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2071	else	2061	else
2072	return 0;	2062	return 0;
2073	}	2063	}
2074	#endif	2064	#endif
2075		2065
2076	INTERFACE void	2066	ecb_cold INTERFACE void
2077	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2078	{	2068	{
2079	#if USE_PORTS	2069	#if USE_PORTS
2080	port *pt = port (SCHEME_V->outport);	2070	port *pt = port (SCHEME_V->outport);
2081		2071
…		…
2091	#else	2081	#else
2092	write (pt->rep.stdio.file, s, strlen (s));	2082	write (pt->rep.stdio.file, s, strlen (s));
2093	#endif	2083	#endif
2094	}	2084	}
2095		2085
2096	static void	2086	ecb_cold static void
2097	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2098	{	2088	{
2099	#if USE_PORTS	2089	#if USE_PORTS
2100	port *pt = port (SCHEME_V->outport);	2090	port *pt = port (SCHEME_V->outport);
2101		2091
…		…
2115	#else	2105	#else
2116	write (1, s, len);	2106	write (1, s, len);
2117	#endif	2107	#endif
2118	}	2108	}
2119		2109
2120	INTERFACE void	2110	ecb_cold INTERFACE void
2121	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2122	{	2112	{
2123	#if USE_PORTS	2113	#if USE_PORTS
2124	port *pt = port (SCHEME_V->outport);	2114	port *pt = port (SCHEME_V->outport);
2125		2115
…		…
2141	write (1, &c, 1);	2131	write (1, &c, 1);
2142	#endif	2132	#endif
2143	}	2133	}
2144		2134
2145	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2146	static char *	2136	ecb_cold static char *
2147	readstr_upto (SCHEME_P_ int skip, const char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2148	{	2138	{
2149	char *p = SCHEME_V->strbuff + skip;	2139	char *p = SCHEME_V->strbuff + skip;
2150		2140
2151	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))));
…		…
2160		2150
2161	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2162	}	2152	}
2163		2153
2164	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2165	static pointer	2155	ecb_cold static pointer
2166	readstrexp (SCHEME_P_ char delim)	2156	readstrexp (SCHEME_P_ char delim)
2167	{	2157	{
2168	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2169	int c;	2159	int c;
2170	int c1 = 0;	2160	int c1 = 0;
…		…
2203	case '7':	2193	case '7':
2204	state = st_oct1;	2194	state = st_oct1;
2205	c1 = c - '0';	2195	c1 = c - '0';
2206	break;	2196	break;
2207		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
2208	case 'x':	2206	case 'x':
2209	case 'X':	2207	case 'X':
2210	state = st_x1;	2208	state = st_x1;
2211	c1 = 0;	2209	c1 = 0;
2212	break;
2213
2214	case 'n':
2215	*p++ = '\n';
2216	state = st_ok;
2217	break;
2218
2219	case 't':
2220	*p++ = '\t';
2221	state = st_ok;
2222	break;
2223
2224	case 'r':
2225	*p++ = '\r';
2226	state = st_ok;
2227	break;	2210	break;
2228		2211
2229	default:	2212	default:
2230	*p++ = c;	2213	*p++ = c;
2231	state = st_ok;	2214	state = st_ok;
…		…
2283	}	2266	}
2284	}	2267	}
2285	}	2268	}
2286		2269
2287	/* check c is in chars */	2270	/* check c is in chars */
2288	ecb_inline int	2271	ecb_cold int
2289	is_one_of (const char *s, int c)	2272	is_one_of (const char *s, int c)
2290	{	2273	{
2291	return c == EOF || !!strchr (s, c);	2274	return c == EOF || !!strchr (s, c);
2292	}	2275	}
2293		2276
2294	/* skip white characters */	2277	/* skip white characters */
2295	ecb_inline int	2278	ecb_cold int
2296	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2297	{	2280	{
2298	int c, curr_line = 0;	2281	int c, curr_line = 0;
2299		2282
2300	do	2283	do
…		…
2320	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2321	return 1;	2304	return 1;
2322	}	2305	}
2323		2306
2324	/* get token */	2307	/* get token */
2325	static int	2308	ecb_cold static int
2326	token (SCHEME_P)	2309	token (SCHEME_P)
2327	{	2310	{
2328	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2329		2312
2330	if (c == EOF)	2313	if (c == EOF)
…		…
2428	}	2411	}
2429		2412
2430	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2431	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2432		2415
2433	static void	2416	ecb_cold static void
2434	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2435	{	2418	{
2436	int i;	2419	int i;
2437	unsigned char *s = (unsigned char *) p;	2420	unsigned char *s = (unsigned char *) p;
2438		2421
…		…
2494		2477
2495	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2496	}	2479	}
2497		2480
2498	/* print atoms */	2481	/* print atoms */
2499	static void	2482	ecb_cold static void
2500	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2501	{	2484	{
2502	char *p;	2485	char *p;
2503	int len;	2486	int len;
2504		2487
2505	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2506	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2507	}	2490	}
2508		2491
2509	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2510	static void	2493	ecb_cold static void
2511	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2512	{	2495	{
2513	char *p;	2496	char *p;
2514		2497
2515	if (l == NIL)	2498	if (l == NIL)
…		…
2722	return car (d);	2705	return car (d);
2723		2706
2724	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2725	q = p;	2708	q = p;
2726		2709
2727	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2728	{	2711	{
2729	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2730		2713
2731	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2732	p = cdr (d);	2715	p = cdr (d);
2733	}	2716	}
2734		2717
2735	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2736	return q;	2719	return q;
2737	}	2720	}
2738		2721
2739	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2740	static pointer	2723	ecb_hot static pointer
2741	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2742	{	2725	{
2743	/* a must be checked by gc */	2726	/* a must be checked by gc */
2744	pointer p = NIL;	2727	pointer p = NIL;
2745		2728
…		…
2748		2731
2749	return p;	2732	return p;
2750	}	2733	}
2751		2734
2752	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2753	static pointer	2736	ecb_hot static pointer
2754	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2755	{	2738	{
2756	pointer result = term;	2739	pointer result = term;
2757	pointer p = list;	2740	pointer p = list;
2758		2741
…		…
2766		2749
2767	return result;	2750	return result;
2768	}	2751	}
2769		2752
2770	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2771	static pointer	2754	ecb_hot static pointer
2772	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2773	{	2756	{
2774	pointer result = a;	2757	pointer result = a;
2775	pointer p = b;	2758	pointer p = b;
2776		2759
…		…
2785		2768
2786	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2787	}	2770	}
2788		2771
2789	/* equivalence of atoms */	2772	/* equivalence of atoms */
2790	int	2773	ecb_hot int
2791	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2792	{	2775	{
2793	if (is_string (a))	2776	if (is_string (a))
2794	{	2777	{
2795	if (is_string (b))	2778	if (is_string (b))
…		…
2889	}	2872	}
2890	else	2873	else
2891	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2892	}	2875	}
2893		2876
2894	static pointer	2877	ecb_hot static pointer
2895	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)
2896	{	2879	{
2897	pointer x, y;	2880	pointer x, y;
2898		2881
2899	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
…		…
2920	return NIL;	2903	return NIL;
2921	}	2904	}
2922		2905
2923	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2924		2907
2925	ecb_inline void	2908	static void
2926	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2927	{	2910	{
2928	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2929	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2930	}	2913	}
2931		2914
2932	ecb_inline void	2915	static void
2933	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)
2934	{	2917	{
2935	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2936	}	2919	}
2937		2920
2938	static pointer	2921	ecb_hot static pointer
2939	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)
2940	{	2923	{
2941	pointer x, y;	2924	pointer x, y;
2942		2925
2943	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2957	return NIL;	2940	return NIL;
2958	}	2941	}
2959		2942
2960	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2961		2944
2962	ecb_inline void	2945	static void
2963	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2964	{	2947	{
2965	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2	2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2966	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);
2967	}	2950	}
2968		2951
2969	ecb_inline void	2952	static void
2970	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2971	{	2954	{
2972	set_cdr (slot, value);	2955	set_cdr (slot, value);
2973	}	2956	}
2974		2957
2975	ecb_inline pointer	2958	static pointer
2976	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2977	{	2960	{
2978	return cdr (slot);	2961	return cdr (slot);
2979	}	2962	}
2980		2963
2981	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2982		2965
2983	static int	2966	ecb_cold static int
2984	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2985	{	2968	{
2986	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2987	pointer x;	2970	pointer x;
2988	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3064	pointer code;	3047	pointer code;
3065	};	3048	};
3066		3049
3067	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3068		3051
3069	static void	3052	ecb_hot static void
3070	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)
3071	{	3054	{
3072	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3073	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3074		3057
…		…
3087	next_frame->code = code;	3070	next_frame->code = code;
3088		3071
3089	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3090	}	3073	}
3091		3074
3092	static int	3075	static ecb_hot int
3093	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3094	{	3077	{
3095	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3096	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3097		3080
…		…
3108	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3109		3092
3110	return 0;	3093	return 0;
3111	}	3094	}
3112		3095
3113	ecb_inline void	3096	ecb_cold void
3114	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3115	{	3098	{
3116	/* 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 */
3117	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3118	}	3101	}
3119		3102
3120	ecb_inline void	3103	ecb_cold void
3121	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3122	{	3105	{
3123	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3124	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3125	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3126	}	3109	}
3127		3110
3128	static void	3111	ecb_cold static void
3129	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3130	{	3113	{
3131	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3132	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3133	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3134	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3135	}	3118	}
3136		3119
3137	static void	3120	ecb_cold static void
3138	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3139	{	3122	{
3140	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3141	int i;	3124	int i;
3142		3125
…		…
3148	mark (frame->envir);	3131	mark (frame->envir);
3149	mark (frame->code);	3132	mark (frame->code);
3150	}	3133	}
3151	}	3134	}
3152		3135
3153	static pointer	3136	ecb_cold static pointer
3154	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3155	{	3138	{
3156	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3157	int i;	3140	int i;
3158		3141
…		…
3170	}	3153	}
3171		3154
3172	return cont;	3155	return cont;
3173	}	3156	}
3174		3157
3175	static void	3158	ecb_cold static void
3176	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3177	{	3160	{
3178	int i = 0;	3161	int i = 0;
3179	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3180		3163
…		…
3192	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3193	}	3176	}
3194		3177
3195	#else	3178	#else
3196		3179
3197	ecb_inline void	3180	ecb_cold void
3198	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3199	{	3182	{
3200	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3201	}	3184	}
3202		3185
3203	ecb_inline void	3186	ecb_cold void
3204	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3205	{	3188	{
3206	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3207	}	3190	}
3208		3191
3209	static void	3192	ecb_cold static void
3210	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3211	{	3194	{
3212	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3213	}	3196	}
3214		3197
3215	static int	3198	ecb_hot static int
3216	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3217	{	3200	{
3218	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3219		3202
3220	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
…		…
3230	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3231		3214
3232	return 0;	3215	return 0;
3233	}	3216	}
3234		3217
3235	static void	3218	ecb_hot static void
3236	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)
3237	{	3220	{
3238	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3239	cons (args,	3222	cons (args,
3240	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3241	cons (code,	3224	cons (code,
3242	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3243	}	3226	}
3244		3227
3245	static void	3228	ecb_cold static void
3246	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3247	{	3230	{
3248	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3249	}	3232	}
3250		3233
3251	static pointer	3234	ecb_cold static pointer
3252	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3253	{	3236	{
3254	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3255	}	3238	}
3256		3239
3257	static void	3240	ecb_cold static void
3258	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3259	{	3242	{
3260	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3261	}	3244	}
3262		3245
…		…
3320	break;	3303	break;
3321	}	3304	}
3322	}	3305	}
3323	#endif	3306	#endif
3324		3307
3325	static int	3308	/* syntax, eval, core, ... */
		3309	ecb_hot static int
3326	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3327	{	3311	{
3328	pointer args = SCHEME_V->args;	3312	pointer args = SCHEME_V->args;
3329	pointer x, y;	3313	pointer x, y;
3330		3314
…		…
4016	}	4000	}
4017		4001
4018	if (USE_ERROR_CHECKING) abort ();	4002	if (USE_ERROR_CHECKING) abort ();
4019	}	4003	}
4020		4004
4021	static int	4005	/* math, cxr */
		4006	ecb_hot static int
4022	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4023	{	4008	{
4024	pointer args = SCHEME_V->args;	4009	pointer args = SCHEME_V->args;
4025	pointer x = car (args);	4010	pointer x = car (args);
4026	num v;	4011	num v;
4027		4012
4028	switch (op)	4013	switch (op)
4029	{	4014	{
4030	#if USE_MATH	4015	#if USE_MATH
4031	case OP_INEX2EX: /* inexact->exact */	4016	case OP_INEX2EX: /* inexact->exact */
4032	{
4033	if (is_integer (x))	4017	if (!is_integer (x))
4034	s_return (x);	4018	{
4035
4036	RVALUE r = rvalue_unchecked (x);	4019	RVALUE r = rvalue_unchecked (x);
4037		4020
4038	if (r == (RVALUE)(IVALUE)r)	4021	if (r == (RVALUE)(IVALUE)r)
4039	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));	4022	x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4040	else	4023	else
4041	Error_1 ("inexact->exact: not integral:", x);	4024	Error_1 ("inexact->exact: not integral:", x);
4042	}	4025	}
4043		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))));
4044	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))));
4045	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))))));
4046	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))));
4047	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))));
4048	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))));
4049	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))));
4050	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))));
4051		4043
4052	case OP_ATAN:	4044	case OP_ATAN:
		4045	s_return (mk_real (SCHEME_A_
4053	if (cdr (args) == NIL)	4046	cdr (args) == NIL
4054	s_return (mk_real (SCHEME_A_ atan (rvalue (x))));	4047	? atan (rvalue (x))
4055	else	4048	: atan2 (rvalue (x), rvalue (cadr (args)))));
4056	{
4057	pointer y = cadr (args);
4058	s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4059	}
4060
4061	case OP_SQRT:
4062	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4063		4049
4064	case OP_EXPT:	4050	case OP_EXPT:
4065	{	4051	{
4066	RVALUE result;	4052	RVALUE result;
4067	int real_result = 1;	4053	int real_result = 1;
…		…
4090	if (real_result)	4076	if (real_result)
4091	s_return (mk_real (SCHEME_A_ result));	4077	s_return (mk_real (SCHEME_A_ result));
4092	else	4078	else
4093	s_return (mk_integer (SCHEME_A_ result));	4079	s_return (mk_integer (SCHEME_A_ result));
4094	}	4080	}
4095
4096	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4097	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4098
4099	case OP_TRUNCATE:
4100	{
4101	RVALUE n = rvalue (x);
4102	s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4103	}
4104
4105	case OP_ROUND:
4106	if (is_integer (x))
4107	s_return (x);
4108
4109	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4110	#endif	4081	#endif
4111		4082
4112	case OP_ADD: /* + */	4083	case OP_ADD: /* + */
4113	v = num_zero;	4084	v = num_zero;
4114		4085
…		…
4416	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4387	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4417		4388
4418	s_return (newstr);	4389	s_return (newstr);
4419	}	4390	}
4420		4391
4421	case OP_SUBSTR: /* substring */	4392	case OP_STRING_COPY: /* substring/string-copy */
4422	{	4393	{
4423	char *str = strvalue (x);	4394	char *str = strvalue (x);
4424	int index0 = ivalue_unchecked (cadr (args));	4395	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4425	int index1;	4396	int index1;
4426	int len;	4397	int len;
4427		4398
4428	if (index0 > strlength (x))	4399	if (index0 > strlength (x))
4429	Error_1 ("substring: start out of bounds:", cadr (args));	4400	Error_1 ("string->copy: start out of bounds:", cadr (args));
4430		4401
4431	if (cddr (args) != NIL)	4402	if (cddr (args) != NIL)
4432	{	4403	{
4433	index1 = ivalue_unchecked (caddr (args));	4404	index1 = ivalue_unchecked (caddr (args));
4434		4405
4435	if (index1 > strlength (x) || index1 < index0)	4406	if (index1 > strlength (x) || index1 < index0)
4436	Error_1 ("substring: end out of bounds:", caddr (args));	4407	Error_1 ("string->copy: end out of bounds:", caddr (args));
4437	}	4408	}
4438	else	4409	else
4439	index1 = strlength (x);	4410	index1 = strlength (x);
4440		4411
4441	len = index1 - index0;	4412	len = index1 - index0;
4442	x = mk_empty_string (SCHEME_A_ len, ' ');	4413	x = mk_counted_string (SCHEME_A_ str + index0, len);
4443	memcpy (strvalue (x), str + index0, len);
4444	strvalue (x)[len] = 0;
4445		4414
4446	s_return (x);	4415	s_return (x);
4447	}	4416	}
4448		4417
4449	case OP_VECTOR: /* vector */	4418	case OP_VECTOR: /* vector */
…		…
4523	}	4492	}
4524		4493
4525	if (USE_ERROR_CHECKING) abort ();	4494	if (USE_ERROR_CHECKING) abort ();
4526	}	4495	}
4527		4496
4528	static int	4497	/* relational ops */
		4498	ecb_hot static int
4529	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4499	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4530	{	4500	{
4531	pointer x = SCHEME_V->args;	4501	pointer x = SCHEME_V->args;
4532		4502
4533	for (;;)	4503	for (;;)
…		…
4554	}	4524	}
4555		4525
4556	s_return (S_T);	4526	s_return (S_T);
4557	}	4527	}
4558		4528
4559	static int	4529	/* predicates */
		4530	ecb_hot static int
4560	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4531	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4561	{	4532	{
4562	pointer args = SCHEME_V->args;	4533	pointer args = SCHEME_V->args;
4563	pointer a = car (args);	4534	pointer a = car (args);
4564	pointer d = cdr (args);	4535	pointer d = cdr (args);
…		…
4611	}	4582	}
4612		4583
4613	s_retbool (r);	4584	s_retbool (r);
4614	}	4585	}
4615		4586
4616	static int	4587	/* promises, list ops, ports */
		4588	ecb_hot static int
4617	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4589	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4618	{	4590	{
4619	pointer args = SCHEME_V->args;	4591	pointer args = SCHEME_V->args;
4620	pointer a = car (args);	4592	pointer a = car (args);
4621	pointer x, y;	4593	pointer x, y;
…		…
4638	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4610	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4639	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);	4611	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4640	s_return (SCHEME_V->value);	4612	s_return (SCHEME_V->value);
4641		4613
4642	#if USE_PORTS	4614	#if USE_PORTS
		4615
		4616	case OP_EOF_OBJECT: /* eof-object */
		4617	s_return (S_EOF);
4643		4618
4644	case OP_WRITE: /* write */	4619	case OP_WRITE: /* write */
4645	case OP_DISPLAY: /* display */	4620	case OP_DISPLAY: /* display */
4646	case OP_WRITE_CHAR: /* write-char */	4621	case OP_WRITE_CHAR: /* write-char */
4647	if (is_pair (cdr (SCHEME_V->args)))	4622	if (is_pair (cdr (SCHEME_V->args)))
…		…
4920	}	4895	}
4921		4896
4922	if (USE_ERROR_CHECKING) abort ();	4897	if (USE_ERROR_CHECKING) abort ();
4923	}	4898	}
4924		4899
4925	static int	4900	/* reading */
		4901	ecb_cold static int
4926	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4927	{	4903	{
4928	pointer args = SCHEME_V->args;	4904	pointer args = SCHEME_V->args;
4929	pointer x;	4905	pointer x;
4930		4906
…		…
5272	}	5248	}
5273		5249
5274	if (USE_ERROR_CHECKING) abort ();	5250	if (USE_ERROR_CHECKING) abort ();
5275	}	5251	}
5276		5252
5277	static int	5253	/* list ops */
		5254	ecb_hot static int
5278	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5279	{	5256	{
5280	pointer args = SCHEME_V->args;	5257	pointer args = SCHEME_V->args;
5281	pointer a = car (args);	5258	pointer a = car (args);
5282	pointer x, y;	5259	pointer x, y;
…		…
5340		5317
5341	/* 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 */
5342	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5343		5320
5344	typedef int (*test_predicate)(pointer);	5321	typedef int (*test_predicate)(pointer);
5345	static int	5322
		5323	ecb_hot static int
5346	tst_any (pointer p)	5324	tst_any (pointer p)
5347	{	5325	{
5348	return 1;	5326	return 1;
5349	}	5327	}
5350		5328
5351	static int	5329	ecb_hot static int
5352	tst_inonneg (pointer p)	5330	tst_inonneg (pointer p)
5353	{	5331	{
5354	return is_integer (p) && ivalue_unchecked (p) >= 0;	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
5355	}	5333	}
5356		5334
5357	static int	5335	ecb_hot static int
5358	tst_is_list (SCHEME_P_ pointer p)	5336	tst_is_list (SCHEME_P_ pointer p)
5359	{	5337	{
5360	return p == NIL || is_pair (p);	5338	return p == NIL || is_pair (p);
5361	}	5339	}
5362		5340
…		…
5405	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5406	#include "opdefines.h"	5384	#include "opdefines.h"
5407	#undef OP_DEF	5385	#undef OP_DEF
5408	;	5386	;
5409		5387
5410	static const char *	5388	ecb_cold static const char *
5411	opname (int idx)	5389	opname (int idx)
5412	{	5390	{
5413	const char *name = opnames;	5391	const char *name = opnames;
5414		5392
5415	/* 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? */
…		…
5417	name += strlen (name) + 1;	5395	name += strlen (name) + 1;
5418		5396
5419	return *name ? name : "ILLEGAL";	5397	return *name ? name : "ILLEGAL";
5420	}	5398	}
5421		5399
5422	static const char *	5400	ecb_cold static const char *
5423	procname (pointer x)	5401	procname (pointer x)
5424	{	5402	{
5425	return opname (procnum (x));	5403	return opname (procnum (x));
5426	}	5404	}
5427		5405
…		…
5447	#undef OP_DEF	5425	#undef OP_DEF
5448	{0}	5426	{0}
5449	};	5427	};
5450		5428
5451	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5452	static void ecb_hot	5430	ecb_hot static void
5453	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5454	{	5432	{
5455	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5456		5434
5457	for (;;)	5435	for (;;)
…		…
5548	}	5526	}
5549	}	5527	}
5550		5528
5551	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5552		5530
5553	static void	5531	ecb_cold static void
5554	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5555	{	5533	{
5556	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5557	set_typeflag (x, typeflag (x) | T_SYNTAX);	5535	set_typeflag (x, typeflag (x) | T_SYNTAX);
5558	}	5536	}
5559		5537
5560	static void	5538	ecb_cold static void
5561	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5562	{	5540	{
5563	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5564	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5565	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5573	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5574	return y;	5552	return y;
5575	}	5553	}
5576		5554
5577	/* 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! */
5578	static int	5556	ecb_hot static int
5579	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5580	{	5558	{
5581	const char *s = strvalue (p);	5559	const char *s = strvalue (p);
5582		5560
5583	switch (strlength (p))	5561	switch (strlength (p))
…		…
5768		5746
5769	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5770	}	5748	}
5771		5749
5772	#if USE_PORTS	5750	#if USE_PORTS
5773	void	5751	ecb_cold void
5774	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5775	{	5753	{
5776	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5777	}	5755	}
5778		5756
5779	void	5757	ecb_cold void
5780	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)
5781	{	5759	{
5782	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);
5783	}	5761	}
5784		5762
5785	void	5763	ecb_cold void
5786	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5787	{	5765	{
5788	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5789	}	5767	}
5790		5768
5791	void	5769	ecb_cold void
5792	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)
5793	{	5771	{
5794	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);
5795	}	5773	}
5796	#endif	5774	#endif
5797		5775
5798	void	5776	ecb_cold void
5799	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5800	{	5778	{
5801	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5802	}	5780	}
5803		5781
…		…
5851	}	5829	}
5852	}	5830	}
5853	#endif	5831	#endif
5854	}	5832	}
5855		5833
5856	void	5834	ecb_cold void
5857	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5858	{	5836	{
5859	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5860	}	5838	}
5861		5839
5862	void	5840	ecb_cold void
5863	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5864	{	5842	{
5865	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5866	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5867	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5894		5872
5895	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5896	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5897	}	5875	}
5898		5876
5899	void	5877	ecb_cold void
5900	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5901	{	5879	{
5902	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5903	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5904	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
…		…
5918		5896
5919	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5920	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5921	}	5899	}
5922		5900
5923	void	5901	ecb_cold void
5924	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5925	{	5903	{
5926	pointer x;	5904	pointer x;
5927		5905
5928	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5933	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5934	}	5912	}
5935		5913
5936	#if !STANDALONE	5914	#if !STANDALONE
5937		5915
5938	void	5916	ecb_cold void
5939	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5940	{	5918	{
5941	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));
5942	}	5920	}
5943		5921
5944	void	5922	ecb_cold void
5945	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)
5946	{	5924	{
5947	int i;	5925	int i;
5948		5926
5949	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
5950	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
5951	}	5929	}
5952		5930
5953	pointer	5931	ecb_cold pointer
5954	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
5955	{	5933	{
5956	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));
5957	}	5935	}
5958		5936
5959	void	5937	ecb_cold void
5960	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
5961	{	5939	{
5962	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
5963	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
5964	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
5968	/* 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
5969	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
5970	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
5971	}	5949	}
5972		5950
5973	void	5951	ecb_cold void
5974	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
5975	{	5953	{
5976	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
5977	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5978	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5979	/* Pop */	5957	/* Pop */
5980	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5981	}	5959	}
5982		5960
5983	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
5984	pointer	5962	ecb_cold pointer
5985	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
5986	{	5964	{
5987	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
5988		5966
5989	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
5996	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
5997	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
5998	return SCHEME_V->value;	5976	return SCHEME_V->value;
5999	}	5977	}
6000		5978
6001	pointer	5979	ecb_cold pointer
6002	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
6003	{	5981	{
6004	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
6005		5983
6006	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
6018		5996
6019	/* ========== Main ========== */	5997	/* ========== Main ========== */
6020		5998
6021	#if STANDALONE	5999	#if STANDALONE
6022		6000
6023	int	6001	ecb_cold int
6024	main (int argc, char **argv)	6002	main (int argc, char **argv)
6025	{	6003	{
6026	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
6027	scheme ssc;	6005	scheme ssc;
6028	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;

Diff Legend

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