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

Comparing microscheme/scheme.c (file contents):
Revision 1.2 by root, Wed Nov 25 10:01:39 2015 UTC vs.
Revision 1.3 by root, Wed Nov 25 10:30:34 2015 UTC

…		…
237	{	237	{
238	return type (p) == T_VECTOR;	238	return type (p) == T_VECTOR;
239	}	239	}
240		240
241	INTERFACE void fill_vector (pointer vec, pointer obj);	241	INTERFACE void fill_vector (pointer vec, pointer obj);
		242	INTERFACE uint32_t vector_length (pointer vec);
242	INTERFACE pointer vector_elem (pointer vec, int ielem);	243	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
243	INTERFACE void set_vector_elem (pointer vec, int ielem, pointer a);	244	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
		245
		246	INTERFACE uint32_t
		247	vector_length (pointer vec)
		248	{
		249	return vec->object.vector.length;
		250	}
244		251
245	INTERFACE INLINE int	252	INTERFACE INLINE int
246	is_number (pointer p)	253	is_number (pointer p)
247	{	254	{
248	return type (p) == T_NUMBER;	255	return type (p) == T_NUMBER;
…		…
613	static int file_interactive (SCHEME_P);	620	static int file_interactive (SCHEME_P);
614	static INLINE int is_one_of (char *s, int c);	621	static INLINE int is_one_of (char *s, int c);
615	static int alloc_cellseg (SCHEME_P_ int n);	622	static int alloc_cellseg (SCHEME_P_ int n);
616	static long binary_decode (const char *s);	623	static long binary_decode (const char *s);
617	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	624	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
618	static pointer reserve_cells (SCHEME_P_ int n);
619	static pointer get_consecutive_cells (SCHEME_P_ int n);
620	static pointer find_consecutive_cells (SCHEME_P_ int n);
621	static void finalize_cell (SCHEME_P_ pointer a);	625	static void finalize_cell (SCHEME_P_ pointer a);
622	static int count_consecutive_cells (pointer x, int needed);	626	static int count_consecutive_cells (pointer x, int needed);
623	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	627	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
624	static pointer mk_number (SCHEME_P_ const num n);	628	static pointer mk_number (SCHEME_P_ const num n);
625	static char store_string (SCHEME_P_ int len, const char str, char fill);	629	static char store_string (SCHEME_P_ uint32_t len, const char str, char fill);
626	static pointer mk_vector (SCHEME_P_ int len);	630	static pointer mk_vector (SCHEME_P_ uint32_t len);
627	static pointer mk_atom (SCHEME_P_ char *q);	631	static pointer mk_atom (SCHEME_P_ char *q);
628	static pointer mk_sharp_const (SCHEME_P_ char *name);	632	static pointer mk_sharp_const (SCHEME_P_ char *name);
629		633
630	#if USE_PORTS	634	#if USE_PORTS
631	static pointer mk_port (SCHEME_P_ port *p);	635	static pointer mk_port (SCHEME_P_ port *p);
…		…
1008	--SCHEME_V->fcells;	1012	--SCHEME_V->fcells;
1009	return x;	1013	return x;
1010	}	1014	}
1011	}	1015	}
1012		1016
1013	/* make sure that there is a given number of cells free */
1014	static pointer
1015	reserve_cells (SCHEME_P_ int n)
1016	{
1017	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
1018	return NIL;
1019
1020	/* Are there enough cells available? */
1021	if (SCHEME_V->fcells < n)
1022	{
1023	/* If not, try gc'ing some */
1024	gc (SCHEME_A_ NIL, NIL);
1025
1026	if (SCHEME_V->fcells < n)
1027	{
1028	/* If there still aren't, try getting more heap */
1029	if (!alloc_cellseg (SCHEME_A_ 1) && USE_ERROR_CHECKING)
1030	{
1031	SCHEME_V->no_memory = 1;
1032	return NIL;
1033	}
1034	}
1035
1036	if (SCHEME_V->fcells < n && USE_ERROR_CHECKING)
1037	{
1038	/* If all fail, report failure */
1039	SCHEME_V->no_memory = 1;
1040	return NIL;
1041	}
1042	}
1043
1044	return S_T;
1045	}
1046
1047	static pointer
1048	get_consecutive_cells (SCHEME_P_ int n)
1049	{
1050	pointer x;
1051
1052	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
1053	return S_SINK;
1054
1055	/* Are there any cells available? */
1056	x = find_consecutive_cells (SCHEME_A_ n);
1057
1058	if (x != NIL)
1059	return x;
1060
1061	/* If not, try gc'ing some */
1062	gc (SCHEME_A_ NIL, NIL);
1063
1064	for (;;)
1065	{
1066	x = find_consecutive_cells (SCHEME_A_ n);
1067
1068	if (x != NIL)
1069	return x;
1070
1071	/* If there still aren't, try getting more heap */
1072	if (!alloc_cellseg (SCHEME_A_ 1))
1073	{
1074	#if USE_ERROR_CHECKING
1075	SCHEME_V->no_memory = 1;
1076	return S_SINK;
1077	#endif
1078	}
1079	}
1080	}
1081
1082	static int
1083	count_consecutive_cells (pointer x, int needed)
1084	{
1085	int n = 1;
1086
1087	while (cdr (x) == x + 1)
1088	{
1089	x = cdr (x);
1090	n++;
1091
1092	if (n >= needed)
1093	break;
1094	}
1095
1096	return n;
1097	}
1098
1099	static pointer
1100	find_consecutive_cells (SCHEME_P_ int n)
1101	{
1102	pointer *pp = &SCHEME_V->free_cell;
1103
1104	while (*pp != NIL)
1105	{
1106	int cnt = count_consecutive_cells (*pp, n);
1107
1108	if (cnt >= n)
1109	{
1110	pointer x = *pp;
1111
1112	pp = cdr (pp + n - 1);
1113	SCHEME_V->fcells -= n;
1114	return x;
1115	}
1116
1117	pp = &cdr (*pp + cnt - 1);
1118	}
1119
1120	return NIL;
1121	}
1122
1123	/* To retain recent allocs before interpreter knows about them -	1017	/* To retain recent allocs before interpreter knows about them -
1124	Tehom */	1018	Tehom */
1125		1019
1126	static void	1020	static void
1127	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	1021	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
…		…
1150		1044
1151	return cell;	1045	return cell;
1152	}	1046	}
1153		1047
1154	static pointer	1048	static pointer
1155	get_vector_object (SCHEME_P_ int len, pointer init)	1049	get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1156	{	1050	{
1157	pointer cells = get_consecutive_cells (SCHEME_A_ len / 2 + len % 2 + 1);	1051	pointer v = get_cell_x (SCHEME_A_ 0, 0);
		1052	pointer e = malloc (len sizeof (pointer));
1158		1053
1159	#if USE_ERROR_CHECKING	1054	if (!e && USE_ERROR_CHECKING)
1160	if (SCHEME_V->no_memory)
1161	return S_SINK;	1055	return S_SINK;
1162	#endif
1163		1056
1164	/* Record it as a vector so that gc understands it. */	1057	/* Record it as a vector so that gc understands it. */
1165	set_typeflag (cells, T_VECTOR \| T_ATOM);	1058	set_typeflag (v, T_VECTOR \| T_ATOM);
1166	ivalue_unchecked (cells) = len;	1059
1167	set_num_integer (cells);	1060	v->object.vector.vvalue = e;
		1061	v->object.vector.length = len;
1168	fill_vector (cells, init);	1062	fill_vector (v, init);
1169	push_recent_alloc (SCHEME_A_ cells, NIL);	1063	push_recent_alloc (SCHEME_A_ v, NIL);
1170		1064
1171	return cells;	1065	return v;
1172	}	1066	}
1173		1067
1174	static INLINE void	1068	static INLINE void
1175	ok_to_freely_gc (SCHEME_P)	1069	ok_to_freely_gc (SCHEME_P)
1176	{	1070	{
…		…
1212	if (immutable)	1106	if (immutable)
1213	setimmutable (x);	1107	setimmutable (x);
1214		1108
1215	set_car (x, a);	1109	set_car (x, a);
1216	set_cdr (x, b);	1110	set_cdr (x, b);
		1111
1217	return x;	1112	return x;
1218	}	1113	}
1219		1114
1220	/* ========== oblist implementation ========== */	1115	/* ========== oblist implementation ========== */
1221		1116
…		…
1237		1132
1238	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);	1133	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1239	set_typeflag (x, T_SYMBOL);	1134	set_typeflag (x, T_SYMBOL);
1240	setimmutable (car (x));	1135	setimmutable (car (x));
1241		1136
1242	location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist));	1137	location = hash_fn (name, vector_length (SCHEME_V->oblist));
1243	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));	1138	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1244	return x;	1139	return x;
1245	}	1140	}
1246		1141
1247	static INLINE pointer	1142	static INLINE pointer
…		…
1249	{	1144	{
1250	int location;	1145	int location;
1251	pointer x;	1146	pointer x;
1252	char *s;	1147	char *s;
1253		1148
1254	location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist));	1149	location = hash_fn (name, vector_length (SCHEME_V->oblist));
1255		1150
1256	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1151	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1257	{	1152	{
1258	s = symname (car (x));	1153	s = symname (car (x));
1259		1154
…		…
1270	{	1165	{
1271	int i;	1166	int i;
1272	pointer x;	1167	pointer x;
1273	pointer ob_list = NIL;	1168	pointer ob_list = NIL;
1274		1169
1275	for (i = 0; i < ivalue_unchecked (SCHEME_V->oblist); i++)	1170	for (i = 0; i < vector_length (SCHEME_V->oblist); i++)
1276	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1171	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1277	ob_list = cons (x, ob_list);	1172	ob_list = cons (x, ob_list);
1278		1173
1279	return ob_list;	1174	return ob_list;
1280	}	1175	}
…		…
1393	return mk_real (SCHEME_A_ num_get_rvalue (n));	1288	return mk_real (SCHEME_A_ num_get_rvalue (n));
1394	}	1289	}
1395		1290
1396	/* allocate name to string area */	1291	/* allocate name to string area */
1397	static char *	1292	static char *
1398	store_string (SCHEME_P_ int len_str, const char *str, char fill)	1293	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
1399	{	1294	{
1400	char *q = malloc (len_str + 1);	1295	char *q = malloc (len_str + 1);
1401		1296
1402	if (q == 0 && USE_ERROR_CHECKING)	1297	if (q == 0 && USE_ERROR_CHECKING)
1403	{	1298	{
…		…
1430	{	1325	{
1431	return mk_counted_string (SCHEME_A_ str, strlen (str));	1326	return mk_counted_string (SCHEME_A_ str, strlen (str));
1432	}	1327	}
1433		1328
1434	INTERFACE pointer	1329	INTERFACE pointer
1435	mk_counted_string (SCHEME_P_ const char *str, int len)	1330	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1436	{	1331	{
1437	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1332	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1438		1333
1439	set_typeflag (x, T_STRING \| T_ATOM);	1334	set_typeflag (x, T_STRING \| T_ATOM);
1440	strvalue (x) = store_string (SCHEME_A_ len, str, 0);	1335	strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1441	strlength (x) = len;	1336	strlength (x) = len;
1442	return x;	1337	return x;
1443	}	1338	}
1444		1339
1445	INTERFACE pointer	1340	INTERFACE pointer
1446	mk_empty_string (SCHEME_P_ int len, char fill)	1341	mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1447	{	1342	{
1448	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1343	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1449		1344
1450	set_typeflag (x, T_STRING \| T_ATOM);	1345	set_typeflag (x, T_STRING \| T_ATOM);
1451	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);	1346	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1452	strlength (x) = len;	1347	strlength (x) = len;
1453	return x;	1348	return x;
1454	}	1349	}
1455		1350
1456	INTERFACE pointer	1351	INTERFACE pointer
1457	mk_vector (SCHEME_P_ int len)	1352	mk_vector (SCHEME_P_ uint32_t len)
1458	{	1353	{
1459	return get_vector_object (SCHEME_A_ len, NIL);	1354	return get_vector_object (SCHEME_A_ len, NIL);
1460	}	1355	}
1461		1356
1462	INTERFACE void	1357	INTERFACE void
1463	fill_vector (pointer vec, pointer obj)	1358	fill_vector (pointer vec, pointer obj)
1464	{	1359	{
1465	int i;	1360	int i;
1466	int num = ivalue (vec) / 2 + ivalue (vec) % 2;
1467		1361
1468	for (i = 0; i < num; i++)	1362	for (i = 0; i < vec->object.vector.length; i++)
1469	{	1363	vec->object.vector.vvalue[i] = obj;
1470	set_typeflag (vec + 1 + i, T_PAIR);
1471	setimmutable (vec + 1 + i);
1472	set_car (vec + 1 + i, obj);
1473	set_cdr (vec + 1 + i, obj);
1474	}
1475	}	1364	}
1476		1365
1477	INTERFACE pointer	1366	INTERFACE pointer
1478	vector_elem (pointer vec, int ielem)	1367	vector_elem (pointer vec, uint32_t ielem)
1479	{	1368	{
1480	int n = ielem / 2;	1369	return vec->object.vector.vvalue[ielem];
1481
1482	if (ielem % 2 == 0)
1483	return car (vec + 1 + n);
1484	else
1485	return cdr (vec + 1 + n);
1486	}	1370	}
1487		1371
1488	INTERFACE void	1372	INTERFACE void
1489	set_vector_elem (pointer vec, int ielem, pointer a)	1373	set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1490	{	1374	{
1491	int n = ielem / 2;	1375	vec->object.vector.vvalue[ielem] = a;
1492
1493	if (ielem % 2 == 0)
1494	set_car (vec + 1 + n, a);
1495	else
1496	set_cdr (vec + 1 + n, a);
1497	}	1376	}
1498		1377
1499	/* get new symbol */	1378	/* get new symbol */
1500	INTERFACE pointer	1379	INTERFACE pointer
1501	mk_symbol (SCHEME_P_ const char *name)	1380	mk_symbol (SCHEME_P_ const char *name)
…		…
1707	setmark (p);	1586	setmark (p);
1708		1587
1709	if (is_vector (p))	1588	if (is_vector (p))
1710	{	1589	{
1711	int i;	1590	int i;
1712	int num = ivalue_unchecked (p) / 2 + ivalue_unchecked (p) % 2;
1713		1591
1714	for (i = 0; i < num; i++)	1592	for (i = 0; i < p->object.vector.length; i++)
1715	{	1593	mark (p->object.vector.vvalue[i]);
1716	/* Vector cells will be treated like ordinary cells */
1717	mark (p + 1 + i);
1718	}
1719	}	1594	}
1720		1595
1721	if (is_atom (p))	1596	if (is_atom (p))
1722	goto E6;	1597	goto E6;
1723		1598
…		…
1843	static void	1718	static void
1844	finalize_cell (SCHEME_P_ pointer a)	1719	finalize_cell (SCHEME_P_ pointer a)
1845	{	1720	{
1846	if (is_string (a))	1721	if (is_string (a))
1847	free (strvalue (a));	1722	free (strvalue (a));
		1723	else if (is_vector (a))
		1724	free (a->object.vector.vvalue);
1848	#if USE_PORTS	1725	#if USE_PORTS
1849	else if (is_port (a))	1726	else if (is_port (a))
1850	{	1727	{
1851	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)	1728	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1852	port_close (SCHEME_A_ a, port_input \| port_output);	1729	port_close (SCHEME_A_ a, port_input \| port_output);
…		…
2985	#if !defined(USE_ALIST_ENV) \|\| !defined(USE_OBJECT_LIST)	2862	#if !defined(USE_ALIST_ENV) \|\| !defined(USE_OBJECT_LIST)
2986		2863
2987	static int	2864	static int
2988	hash_fn (const char *key, int table_size)	2865	hash_fn (const char *key, int table_size)
2989	{	2866	{
2990	unsigned int hashed = 0;	2867	const unsigned char *p = key;
2991	const char *c;	2868	uint32_t hash = 2166136261;
2992	int bits_per_int = sizeof (unsigned int) * 8;
2993		2869
2994	for (c = key; *c; c++)	2870	while (*p)
2995	{	2871	hash = (hash ^ p++) 16777619;
2996	/* letters have about 5 bits in them */
2997	hashed = (hashed << 5) \| (hashed >> (bits_per_int - 5));
2998	hashed ^= *c;
2999	}
3000		2872
3001	return hashed % table_size;	2873	return hash % table_size;
3002	}	2874	}
3003	#endif	2875	#endif
3004		2876
3005	#ifndef USE_ALIST_ENV	2877	#ifndef USE_ALIST_ENV
3006		2878
…		…
3032	{	2904	{
3033	pointer slot = immutable_cons (variable, value);	2905	pointer slot = immutable_cons (variable, value);
3034		2906
3035	if (is_vector (car (env)))	2907	if (is_vector (car (env)))
3036	{	2908	{
3037	int location = hash_fn (symname (variable), ivalue_unchecked (car (env)));	2909	int location = hash_fn (symname (variable), vector_length (car (env)));
3038		2910
3039	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2911	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
3040	}	2912	}
3041	else	2913	else
3042	set_car (env, immutable_cons (slot, car (env)));	2914	set_car (env, immutable_cons (slot, car (env)));
…		…
3050		2922
3051	for (x = env; x != NIL; x = cdr (x))	2923	for (x = env; x != NIL; x = cdr (x))
3052	{	2924	{
3053	if (is_vector (car (x)))	2925	if (is_vector (car (x)))
3054	{	2926	{
3055	location = hash_fn (symname (hdl), ivalue_unchecked (car (x)));	2927	location = hash_fn (symname (hdl), vector_length (car (x)));
3056	y = vector_elem (car (x), location);	2928	y = vector_elem (car (x), location);
3057	}	2929	}
3058	else	2930	else
3059	y = car (x);	2931	y = car (x);
3060		2932
…		…
4633		4505
4634	s_return (vec);	4506	s_return (vec);
4635	}	4507	}
4636		4508
4637	case OP_VECLEN: /* vector-length */	4509	case OP_VECLEN: /* vector-length */
4638	s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args))));	4510	s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args))));
4639		4511
4640	case OP_VECREF: /* vector-ref */	4512	case OP_VECREF: /* vector-ref */
4641	{	4513	{
4642	int index;	4514	int index;
4643		4515
4644	index = ivalue (cadr (SCHEME_V->args));	4516	index = ivalue (cadr (SCHEME_V->args));
4645		4517
4646	if (index >= ivalue (car (SCHEME_V->args)))	4518	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4647	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));	4519	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4648		4520
4649	s_return (vector_elem (car (SCHEME_V->args), index));	4521	s_return (vector_elem (car (SCHEME_V->args), index));
4650	}	4522	}
4651		4523
…		…
4656	if (is_immutable (car (SCHEME_V->args)))	4528	if (is_immutable (car (SCHEME_V->args)))
4657	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));	4529	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4658		4530
4659	index = ivalue (cadr (SCHEME_V->args));	4531	index = ivalue (cadr (SCHEME_V->args));
4660		4532
4661	if (index >= ivalue (car (SCHEME_V->args)))	4533	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4662	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));	4534	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4663		4535
4664	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));	4536	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4665	s_return (car (SCHEME_V->args));	4537	s_return (car (SCHEME_V->args));
4666	}	4538	}
…		…
5509		5381
5510	case OP_PVECFROM:	5382	case OP_PVECFROM:
5511	{	5383	{
5512	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5384	int i = ivalue_unchecked (cdr (SCHEME_V->args));
5513	pointer vec = car (SCHEME_V->args);	5385	pointer vec = car (SCHEME_V->args);
5514	int len = ivalue_unchecked (vec);	5386	int len = vector_length (vec);
5515		5387
5516	if (i == len)	5388	if (i == len)
5517	{	5389	{
5518	putstr (SCHEME_A_ ")");	5390	putstr (SCHEME_A_ ")");
5519	s_return (S_T);	5391	s_return (S_T);

Diff Legend

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

Comparing microscheme/scheme.c (file contents): Revision 1.2 by root, Wed Nov 25 10:01:39 2015 UTC vs. Revision 1.3 by root, Wed Nov 25 10:30:34 2015 UTC

Diff Legend

Comparing microscheme/scheme.c (file contents):
Revision 1.2 by root, Wed Nov 25 10:01:39 2015 UTC vs.
Revision 1.3 by root, Wed Nov 25 10:30:34 2015 UTC