[ViewVC] Diff of: cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.58 by root, Tue Dec 1 05:12:33 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"))
…		…
1529	}	1529	}
1530	}	1530	}
1531		1531
1532	/* ========== garbage collector ========== */	1532	/* ========== garbage collector ========== */
1533		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	}
		1552
1534	/*--	1553	/*--
1535	* 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,
1536	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1537	* for marking.	1556	* for marking.
1538	*	1557	*
1539	* The exception is vectors - vectors are currently marked recursively,	1558	* The exception is vectors - vectors are currently marked recursively,
1540	* 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
1541	* word of context in the vector	1560	* word of context in the vector
1542	*/	1561	*/
1543	static void	1562	ecb_hot static void
1544	mark (pointer a)	1563	mark (pointer a)
1545	{	1564	{
1546	pointer t, q, p;	1565	pointer t, q, p;
1547		1566
1548	t = 0;	1567	t = 0;
…		…
1605	p = q;	1624	p = q;
1606	goto E6;	1625	goto E6;
1607	}	1626	}
1608	}	1627	}
1609		1628
1610	/* garbage collection. parameter a, b is marked. */	1629	ecb_hot static void
1611	static void	1630	gc_free (SCHEME_P)
1612	gc (SCHEME_P_ pointer a, pointer b)
1613	{	1631	{
1614	int i;	1632	int i;
1615
1616	if (SCHEME_V->gc_verbose)
1617	putstr (SCHEME_A_ "gc...");
1618
1619	/* mark system globals */
1620	mark (SCHEME_V->oblist);
1621	mark (SCHEME_V->global_env);
1622
1623	/* mark current registers */
1624	mark (SCHEME_V->args);
1625	mark (SCHEME_V->envir);
1626	mark (SCHEME_V->code);
1627	dump_stack_mark (SCHEME_A);
1628	mark (SCHEME_V->value);
1629	mark (SCHEME_V->inport);
1630	mark (SCHEME_V->save_inport);
1631	mark (SCHEME_V->outport);
1632	mark (SCHEME_V->loadport);
1633
1634	/* Mark recent objects the interpreter doesn't know about yet. */
1635	mark (car (S_SINK));
1636	/* Mark any older stuff above nested C calls */
1637	mark (SCHEME_V->c_nest);
1638
1639	#if USE_INTCACHE
1640	/* mark intcache */
1641	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1642	if (SCHEME_V->intcache[i - INTCACHE_MIN])
1643	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1644	#endif
1645
1646	/* mark variables a, b */
1647	mark (a);
1648	mark (b);
1649
1650	/* garbage collect */
1651	clrmark (NIL);
1652	SCHEME_V->fcells = 0;
1653	SCHEME_V->free_cell = NIL;
1654
1655	if (SCHEME_V->gc_verbose)
1656	putstr (SCHEME_A_ "freeing...");
1657
1658	uint32_t total = 0;	1633	uint32_t total = 0;
1659		1634
1660	/* Here we scan the cells to build the free-list. */	1635	/* Here we scan the cells to build the free-list. */
1661	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)	1636	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1662	{	1637	{
…		…
1691	{	1666	{
1692	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");
1693	}	1668	}
1694	}	1669	}
1695		1670
1696	static void	1671	/* garbage collection. parameter a, b is marked. */
1697	finalize_cell (SCHEME_P_ pointer a)	1672	ecb_cold static void
		1673	gc (SCHEME_P_ pointer a, pointer b)
1698	{	1674	{
1699	/* TODO, fast bitmap check? */	1675	int i;
1700	if (is_string (a) \|\| is_symbol (a))
1701	free (strvalue (a));
1702	else if (is_vector (a))
1703	free (vecvalue (a));
1704	#if USE_PORTS
1705	else if (is_port (a))
1706	{
1707	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1708	port_close (SCHEME_A_ a, port_input \| port_output);
1709		1676
1710	free (port (a));	1677	if (SCHEME_V->gc_verbose)
1711	}	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]);
1712	#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);
1713	}	1720	}
1714		1721
1715	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1716		1723
1717	static int	1724	ecb_cold static int
1718	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1719	{	1726	{
1720	#if USE_PORTS	1727	#if USE_PORTS
1721	int fin;	1728	int fin;
1722		1729
…		…
1748	#else	1755	#else
1749	return 1;	1756	return 1;
1750	#endif	1757	#endif
1751	}	1758	}
1752		1759
1753	static void	1760	ecb_cold static void
1754	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1755	{	1762	{
1756	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1757	{	1764	{
1758	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
…		…
1762	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1763	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);
1764	}	1771	}
1765	}	1772	}
1766		1773
1767	static int	1774	ecb_cold static int
1768	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1769	{	1776	{
1770	#if USE_PORTS	1777	#if USE_PORTS
1771	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1772	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
…		…
1775	return 0;	1782	return 0;
1776	#endif	1783	#endif
1777	}	1784	}
1778		1785
1779	#if USE_PORTS	1786	#if USE_PORTS
1780	static port *	1787	ecb_cold static port *
1781	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1782	{	1789	{
1783	int fd;	1790	int fd;
1784	int flags;	1791	int flags;
1785	char *rw;	1792	char *rw;
…		…
1808	# endif	1815	# endif
1809		1816
1810	return pt;	1817	return pt;
1811	}	1818	}
1812		1819
1813	static pointer	1820	ecb_cold static pointer
1814	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1815	{	1822	{
1816	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1817		1824
1818	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1819	return NIL;	1826	return NIL;
1820		1827
1821	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1822	}	1829	}
1823		1830
1824	static port *	1831	ecb_cold static port *
1825	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1826	{	1833	{
1827	port pt = malloc (sizeof pt);	1834	port pt = malloc (sizeof pt);
1828		1835
1829	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1834	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1835	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1836	return pt;	1843	return pt;
1837	}	1844	}
1838		1845
1839	static pointer	1846	ecb_cold static pointer
1840	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1841	{	1848	{
1842	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1843		1850
1844	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1845	return NIL;	1852	return NIL;
1846		1853
1847	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1848	}	1855	}
1849		1856
1850	static port *	1857	ecb_cold static port *
1851	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)
1852	{	1859	{
1853	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1854		1861
1855	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1861	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1862	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1863	return pt;	1870	return pt;
1864	}	1871	}
1865		1872
1866	static pointer	1873	ecb_cold static pointer
1867	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)
1868	{	1875	{
1869	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);
1870		1877
1871	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1874	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1875	}	1882	}
1876		1883
1877	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1878		1885
1879	static port *	1886	ecb_cold static port *
1880	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1881	{	1888	{
1882	char *start;	1889	char *start;
1883	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1884		1891
…		…
1898	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1899	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1900	return pt;	1907	return pt;
1901	}	1908	}
1902		1909
1903	static pointer	1910	ecb_cold static pointer
1904	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1905	{	1912	{
1906	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1907		1914
1908	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1909	return NIL;	1916	return NIL;
1910		1917
1911	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1912	}	1919	}
1913		1920
1914	static void	1921	ecb_cold static void
1915	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1916	{	1923	{
1917	port *pt = port (p);	1924	port *pt = port (p);
1918		1925
1919	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
…		…
2031	ungot = c;	2038	ungot = c;
2032	#endif	2039	#endif
2033	}	2040	}
2034		2041
2035	#if USE_PORTS	2042	#if USE_PORTS
2036	static int	2043	ecb_cold static int
2037	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2038	{	2045	{
2039	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2040	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;
2041	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2054	else	2061	else
2055	return 0;	2062	return 0;
2056	}	2063	}
2057	#endif	2064	#endif
2058		2065
2059	INTERFACE void	2066	ecb_cold INTERFACE void
2060	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2061	{	2068	{
2062	#if USE_PORTS	2069	#if USE_PORTS
2063	port *pt = port (SCHEME_V->outport);	2070	port *pt = port (SCHEME_V->outport);
2064		2071
…		…
2074	#else	2081	#else
2075	write (pt->rep.stdio.file, s, strlen (s));	2082	write (pt->rep.stdio.file, s, strlen (s));
2076	#endif	2083	#endif
2077	}	2084	}
2078		2085
2079	static void	2086	ecb_cold static void
2080	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2081	{	2088	{
2082	#if USE_PORTS	2089	#if USE_PORTS
2083	port *pt = port (SCHEME_V->outport);	2090	port *pt = port (SCHEME_V->outport);
2084		2091
…		…
2098	#else	2105	#else
2099	write (1, s, len);	2106	write (1, s, len);
2100	#endif	2107	#endif
2101	}	2108	}
2102		2109
2103	INTERFACE void	2110	ecb_cold INTERFACE void
2104	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2105	{	2112	{
2106	#if USE_PORTS	2113	#if USE_PORTS
2107	port *pt = port (SCHEME_V->outport);	2114	port *pt = port (SCHEME_V->outport);
2108		2115
…		…
2124	write (1, &c, 1);	2131	write (1, &c, 1);
2125	#endif	2132	#endif
2126	}	2133	}
2127		2134
2128	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2129	static char *	2136	ecb_cold static char *
2130	readstr_upto (SCHEME_P_ int skip, const char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2131	{	2138	{
2132	char *p = SCHEME_V->strbuff + skip;	2139	char *p = SCHEME_V->strbuff + skip;
2133		2140
2134	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))));
…		…
2143		2150
2144	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2145	}	2152	}
2146		2153
2147	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2148	static pointer	2155	ecb_cold static pointer
2149	readstrexp (SCHEME_P_ char delim)	2156	readstrexp (SCHEME_P_ char delim)
2150	{	2157	{
2151	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2152	int c;	2159	int c;
2153	int c1 = 0;	2160	int c1 = 0;
…		…
2259	}	2266	}
2260	}	2267	}
2261	}	2268	}
2262		2269
2263	/* check c is in chars */	2270	/* check c is in chars */
2264	ecb_inline int	2271	ecb_cold int
2265	is_one_of (const char *s, int c)	2272	is_one_of (const char *s, int c)
2266	{	2273	{
2267	return c == EOF \|\| !!strchr (s, c);	2274	return c == EOF \|\| !!strchr (s, c);
2268	}	2275	}
2269		2276
2270	/* skip white characters */	2277	/* skip white characters */
2271	ecb_inline int	2278	ecb_cold int
2272	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2273	{	2280	{
2274	int c, curr_line = 0;	2281	int c, curr_line = 0;
2275		2282
2276	do	2283	do
…		…
2296	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2297	return 1;	2304	return 1;
2298	}	2305	}
2299		2306
2300	/* get token */	2307	/* get token */
2301	static int	2308	ecb_cold static int
2302	token (SCHEME_P)	2309	token (SCHEME_P)
2303	{	2310	{
2304	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2305		2312
2306	if (c == EOF)	2313	if (c == EOF)
…		…
2404	}	2411	}
2405		2412
2406	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2407	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2408		2415
2409	static void	2416	ecb_cold static void
2410	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2411	{	2418	{
2412	int i;	2419	int i;
2413	unsigned char s = (unsigned char ) p;	2420	unsigned char s = (unsigned char ) p;
2414		2421
…		…
2470		2477
2471	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2472	}	2479	}
2473		2480
2474	/* print atoms */	2481	/* print atoms */
2475	static void	2482	ecb_cold static void
2476	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2477	{	2484	{
2478	char *p;	2485	char *p;
2479	int len;	2486	int len;
2480		2487
2481	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2482	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2483	}	2490	}
2484		2491
2485	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2486	static void	2493	ecb_cold static void
2487	atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen)
2488	{	2495	{
2489	char *p;	2496	char *p;
2490		2497
2491	if (l == NIL)	2498	if (l == NIL)
…		…
2698	return car (d);	2705	return car (d);
2699		2706
2700	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2701	q = p;	2708	q = p;
2702		2709
2703	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2704	{	2711	{
2705	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2706		2713
2707	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2708	p = cdr (d);	2715	p = cdr (d);
2709	}	2716	}
2710		2717
2711	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2712	return q;	2719	return q;
2713	}	2720	}
2714		2721
2715	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2716	static pointer	2723	ecb_hot static pointer
2717	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2718	{	2725	{
2719	/* a must be checked by gc */	2726	/* a must be checked by gc */
2720	pointer p = NIL;	2727	pointer p = NIL;
2721		2728
…		…
2724		2731
2725	return p;	2732	return p;
2726	}	2733	}
2727		2734
2728	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2729	static pointer	2736	ecb_hot static pointer
2730	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2731	{	2738	{
2732	pointer result = term;	2739	pointer result = term;
2733	pointer p = list;	2740	pointer p = list;
2734		2741
…		…
2742		2749
2743	return result;	2750	return result;
2744	}	2751	}
2745		2752
2746	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2747	static pointer	2754	ecb_hot static pointer
2748	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2749	{	2756	{
2750	pointer result = a;	2757	pointer result = a;
2751	pointer p = b;	2758	pointer p = b;
2752		2759
…		…
2761		2768
2762	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2763	}	2770	}
2764		2771
2765	/* equivalence of atoms */	2772	/* equivalence of atoms */
2766	int	2773	ecb_hot int
2767	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2768	{	2775	{
2769	if (is_string (a))	2776	if (is_string (a))
2770	{	2777	{
2771	if (is_string (b))	2778	if (is_string (b))
…		…
2865	}	2872	}
2866	else	2873	else
2867	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2868	}	2875	}
2869		2876
2870	static pointer	2877	ecb_hot static pointer
2871	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)
2872	{	2879	{
2873	pointer x, y;	2880	pointer x, y;
2874		2881
2875	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
…		…
2896	return NIL;	2903	return NIL;
2897	}	2904	}
2898		2905
2899	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2900		2907
2901	ecb_inline void	2908	static void
2902	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2903	{	2910	{
2904	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2905	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2906	}	2913	}
2907		2914
2908	ecb_inline void	2915	static void
2909	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)
2910	{	2917	{
2911	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2912	}	2919	}
2913		2920
2914	static pointer	2921	ecb_hot static pointer
2915	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)
2916	{	2923	{
2917	pointer x, y;	2924	pointer x, y;
2918		2925
2919	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2933	return NIL;	2940	return NIL;
2934	}	2941	}
2935		2942
2936	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2937		2944
2938	ecb_inline void	2945	static void
2939	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2940	{	2947	{
2941	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2	2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2942	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);
2943	}	2950	}
2944		2951
2945	ecb_inline void	2952	static void
2946	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2947	{	2954	{
2948	set_cdr (slot, value);	2955	set_cdr (slot, value);
2949	}	2956	}
2950		2957
2951	ecb_inline pointer	2958	static pointer
2952	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2953	{	2960	{
2954	return cdr (slot);	2961	return cdr (slot);
2955	}	2962	}
2956		2963
2957	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2958		2965
2959	static int	2966	ecb_cold static int
2960	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2961	{	2968	{
2962	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2963	pointer x;	2970	pointer x;
2964	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3040	pointer code;	3047	pointer code;
3041	};	3048	};
3042		3049
3043	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3044		3051
3045	static void	3052	ecb_hot static void
3046	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)
3047	{	3054	{
3048	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3049	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3050		3057
…		…
3063	next_frame->code = code;	3070	next_frame->code = code;
3064		3071
3065	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3066	}	3073	}
3067		3074
3068	static int	3075	static ecb_hot int
3069	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3070	{	3077	{
3071	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3072	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3073		3080
…		…
3084	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3085		3092
3086	return 0;	3093	return 0;
3087	}	3094	}
3088		3095
3089	ecb_inline void	3096	ecb_cold void
3090	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3091	{	3098	{
3092	/* 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 */
3093	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3094	}	3101	}
3095		3102
3096	ecb_inline void	3103	ecb_cold void
3097	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3098	{	3105	{
3099	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3100	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3101	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3102	}	3109	}
3103		3110
3104	static void	3111	ecb_cold static void
3105	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3106	{	3113	{
3107	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3108	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3109	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3110	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3111	}	3118	}
3112		3119
3113	static void	3120	ecb_cold static void
3114	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3115	{	3122	{
3116	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3117	int i;	3124	int i;
3118		3125
…		…
3124	mark (frame->envir);	3131	mark (frame->envir);
3125	mark (frame->code);	3132	mark (frame->code);
3126	}	3133	}
3127	}	3134	}
3128		3135
3129	static pointer	3136	ecb_cold static pointer
3130	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3131	{	3138	{
3132	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3133	int i;	3140	int i;
3134		3141
…		…
3146	}	3153	}
3147		3154
3148	return cont;	3155	return cont;
3149	}	3156	}
3150		3157
3151	static void	3158	ecb_cold static void
3152	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3153	{	3160	{
3154	int i = 0;	3161	int i = 0;
3155	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3156		3163
…		…
3168	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3169	}	3176	}
3170		3177
3171	#else	3178	#else
3172		3179
3173	ecb_inline void	3180	ecb_cold void
3174	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3175	{	3182	{
3176	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3177	}	3184	}
3178		3185
3179	ecb_inline void	3186	ecb_cold void
3180	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3181	{	3188	{
3182	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3183	}	3190	}
3184		3191
3185	static void	3192	ecb_cold static void
3186	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3187	{	3194	{
3188	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3189	}	3196	}
3190		3197
3191	static int	3198	ecb_hot static int
3192	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3193	{	3200	{
3194	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3195		3202
3196	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
…		…
3206	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3207		3214
3208	return 0;	3215	return 0;
3209	}	3216	}
3210		3217
3211	static void	3218	ecb_hot static void
3212	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)
3213	{	3220	{
3214	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3215	cons (args,	3222	cons (args,
3216	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3217	cons (code,	3224	cons (code,
3218	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3219	}	3226	}
3220		3227
3221	static void	3228	ecb_cold static void
3222	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3223	{	3230	{
3224	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3225	}	3232	}
3226		3233
3227	static pointer	3234	ecb_cold static pointer
3228	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3229	{	3236	{
3230	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3231	}	3238	}
3232		3239
3233	static void	3240	ecb_cold static void
3234	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3235	{	3242	{
3236	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3237	}	3244	}
3238		3245
…		…
3296	break;	3303	break;
3297	}	3304	}
3298	}	3305	}
3299	#endif	3306	#endif
3300		3307
3301	static int	3308	/* syntax, eval, core, ... */
		3309	ecb_hot static int
3302	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3303	{	3311	{
3304	pointer args = SCHEME_V->args;	3312	pointer args = SCHEME_V->args;
3305	pointer x, y;	3313	pointer x, y;
3306		3314
…		…
3992	}	4000	}
3993		4001
3994	if (USE_ERROR_CHECKING) abort ();	4002	if (USE_ERROR_CHECKING) abort ();
3995	}	4003	}
3996		4004
3997	static int	4005	/* math, cxr */
		4006	ecb_hot static int
3998	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3999	{	4008	{
4000	pointer args = SCHEME_V->args;	4009	pointer args = SCHEME_V->args;
4001	pointer x = car (args);	4010	pointer x = car (args);
4002	num v;	4011	num v;
…		…
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;
…		…
4883	}	4895	}
4884		4896
4885	if (USE_ERROR_CHECKING) abort ();	4897	if (USE_ERROR_CHECKING) abort ();
4886	}	4898	}
4887		4899
4888	static int	4900	/* reading */
		4901	ecb_cold static int
4889	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4890	{	4903	{
4891	pointer args = SCHEME_V->args;	4904	pointer args = SCHEME_V->args;
4892	pointer x;	4905	pointer x;
4893		4906
…		…
5235	}	5248	}
5236		5249
5237	if (USE_ERROR_CHECKING) abort ();	5250	if (USE_ERROR_CHECKING) abort ();
5238	}	5251	}
5239		5252
5240	static int	5253	/* list ops */
		5254	ecb_hot static int
5241	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5242	{	5256	{
5243	pointer args = SCHEME_V->args;	5257	pointer args = SCHEME_V->args;
5244	pointer a = car (args);	5258	pointer a = car (args);
5245	pointer x, y;	5259	pointer x, y;
…		…
5303		5317
5304	/* 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 */
5305	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5306		5320
5307	typedef int (*test_predicate)(pointer);	5321	typedef int (*test_predicate)(pointer);
5308	static int	5322
		5323	ecb_hot static int
5309	tst_any (pointer p)	5324	tst_any (pointer p)
5310	{	5325	{
5311	return 1;	5326	return 1;
5312	}	5327	}
5313		5328
5314	static int	5329	ecb_hot static int
5315	tst_inonneg (pointer p)	5330	tst_inonneg (pointer p)
5316	{	5331	{
5317	return is_integer (p) && ivalue_unchecked (p) >= 0;	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
5318	}	5333	}
5319		5334
5320	static int	5335	ecb_hot static int
5321	tst_is_list (SCHEME_P_ pointer p)	5336	tst_is_list (SCHEME_P_ pointer p)
5322	{	5337	{
5323	return p == NIL \|\| is_pair (p);	5338	return p == NIL \|\| is_pair (p);
5324	}	5339	}
5325		5340
…		…
5368	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5369	#include "opdefines.h"	5384	#include "opdefines.h"
5370	#undef OP_DEF	5385	#undef OP_DEF
5371	;	5386	;
5372		5387
5373	static const char *	5388	ecb_cold static const char *
5374	opname (int idx)	5389	opname (int idx)
5375	{	5390	{
5376	const char *name = opnames;	5391	const char *name = opnames;
5377		5392
5378	/* 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? */
…		…
5380	name += strlen (name) + 1;	5395	name += strlen (name) + 1;
5381		5396
5382	return *name ? name : "ILLEGAL";	5397	return *name ? name : "ILLEGAL";
5383	}	5398	}
5384		5399
5385	static const char *	5400	ecb_cold static const char *
5386	procname (pointer x)	5401	procname (pointer x)
5387	{	5402	{
5388	return opname (procnum (x));	5403	return opname (procnum (x));
5389	}	5404	}
5390		5405
…		…
5410	#undef OP_DEF	5425	#undef OP_DEF
5411	{0}	5426	{0}
5412	};	5427	};
5413		5428
5414	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5415	static void ecb_hot	5430	ecb_hot static void
5416	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5417	{	5432	{
5418	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5419		5434
5420	for (;;)	5435	for (;;)
…		…
5511	}	5526	}
5512	}	5527	}
5513		5528
5514	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5515		5530
5516	static void	5531	ecb_cold static void
5517	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5518	{	5533	{
5519	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5520	set_typeflag (x, typeflag (x) \| T_SYNTAX);	5535	set_typeflag (x, typeflag (x) \| T_SYNTAX);
5521	}	5536	}
5522		5537
5523	static void	5538	ecb_cold static void
5524	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5525	{	5540	{
5526	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5527	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5528	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5536	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5537	return y;	5552	return y;
5538	}	5553	}
5539		5554
5540	/* 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! */
5541	static int	5556	ecb_hot static int
5542	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5543	{	5558	{
5544	const char *s = strvalue (p);	5559	const char *s = strvalue (p);
5545		5560
5546	switch (strlength (p))	5561	switch (strlength (p))
…		…
5731		5746
5732	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5733	}	5748	}
5734		5749
5735	#if USE_PORTS	5750	#if USE_PORTS
5736	void	5751	ecb_cold void
5737	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5738	{	5753	{
5739	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5740	}	5755	}
5741		5756
5742	void	5757	ecb_cold void
5743	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)
5744	{	5759	{
5745	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);
5746	}	5761	}
5747		5762
5748	void	5763	ecb_cold void
5749	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5750	{	5765	{
5751	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5752	}	5767	}
5753		5768
5754	void	5769	ecb_cold void
5755	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)
5756	{	5771	{
5757	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);
5758	}	5773	}
5759	#endif	5774	#endif
5760		5775
5761	void	5776	ecb_cold void
5762	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5763	{	5778	{
5764	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5765	}	5780	}
5766		5781
…		…
5814	}	5829	}
5815	}	5830	}
5816	#endif	5831	#endif
5817	}	5832	}
5818		5833
5819	void	5834	ecb_cold void
5820	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5821	{	5836	{
5822	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5823	}	5838	}
5824		5839
5825	void	5840	ecb_cold void
5826	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5827	{	5842	{
5828	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5829	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5830	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5857		5872
5858	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5859	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5860	}	5875	}
5861		5876
5862	void	5877	ecb_cold void
5863	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5864	{	5879	{
5865	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5866	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5867	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
…		…
5881		5896
5882	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5883	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5884	}	5899	}
5885		5900
5886	void	5901	ecb_cold void
5887	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5888	{	5903	{
5889	pointer x;	5904	pointer x;
5890		5905
5891	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5896	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5897	}	5912	}
5898		5913
5899	#if !STANDALONE	5914	#if !STANDALONE
5900		5915
5901	void	5916	ecb_cold void
5902	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5903	{	5918	{
5904	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));
5905	}	5920	}
5906		5921
5907	void	5922	ecb_cold void
5908	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)
5909	{	5924	{
5910	int i;	5925	int i;
5911		5926
5912	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
5913	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
5914	}	5929	}
5915		5930
5916	pointer	5931	ecb_cold pointer
5917	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
5918	{	5933	{
5919	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));
5920	}	5935	}
5921		5936
5922	void	5937	ecb_cold void
5923	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
5924	{	5939	{
5925	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
5926	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
5927	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
5931	/* 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
5932	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
5933	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
5934	}	5949	}
5935		5950
5936	void	5951	ecb_cold void
5937	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
5938	{	5953	{
5939	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
5940	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5941	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5942	/* Pop */	5957	/* Pop */
5943	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5944	}	5959	}
5945		5960
5946	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
5947	pointer	5962	ecb_cold pointer
5948	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
5949	{	5964	{
5950	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
5951		5966
5952	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
5959	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
5960	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
5961	return SCHEME_V->value;	5976	return SCHEME_V->value;
5962	}	5977	}
5963		5978
5964	pointer	5979	ecb_cold pointer
5965	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
5966	{	5981	{
5967	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
5968		5983
5969	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
5981		5996
5982	/* ========== Main ========== */	5997	/* ========== Main ========== */
5983		5998
5984	#if STANDALONE	5999	#if STANDALONE
5985		6000
5986	int	6001	ecb_cold int
5987	main (int argc, char **argv)	6002	main (int argc, char **argv)
5988	{	6003	{
5989	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
5990	scheme ssc;	6005	scheme ssc;
5991	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.58 by root, Tue Dec 1 05:12:33 2015 UTC vs. Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.58 by root, Tue Dec 1 05:12:33 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC