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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.6 by root, Wed Nov 25 10:57:17 2015 UTC vs.
Revision 1.8 by root, Wed Nov 25 22:36:25 2015 UTC

…		…
1		1	/*
2	/* T I N Y S C H E M E 1 . 4 1	2	* µscheme
		3	*
		4	* Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
		5	* do as you want with this, attribution appreciated.
		6	*
		7	* Based opn tinyscheme-1.41 (original credits follow)
3	* Dimitrios Souflis (dsouflis@acm.org)	8	* Dimitrios Souflis (dsouflis@acm.org)
4	* Based on MiniScheme (original credits follow)	9	* Based on MiniScheme (original credits follow)
5	* (MINISCM) coded by Atsushi Moriwaki (11/5/1989)	10	* (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
6	* (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp	11	* (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
7	* (MINISCM) This version has been modified by R.C. Secrist.	12	* (MINISCM) This version has been modified by R.C. Secrist.
128	c += 'a' - 'A';	133	c += 'a' - 'A';
129		134
130	return c;	135	return c;
131	}	136	}
132		137
		138	static int
		139	xisdigit (char c)
		140	{
		141	return c >= '0' && c <= '9';
		142	}
		143
		144	#define toupper(c) xtoupper (c)
		145	#define tolower(c) xtolower (c)
		146	#define isdigit(c) xisdigit (c)
		147
133	#if USE_STRLWR	148	#if USE_STRLWR
134	static const char *	149	static const char *
135	strlwr (char *s)	150	strlwr (char *s)
136	{	151	{
137	const char *p = s;	152	const char *p = s;
…		…
146	}	161	}
147	#endif	162	#endif
148		163
149	#define stricmp(a,b) strcmp (a, b)	164	#define stricmp(a,b) strcmp (a, b)
150	#define strlwr(s) (s)	165	#define strlwr(s) (s)
151	#define toupper(c) xtoupper(c)
152	#define tolower(c) xtolower(c)
153		166
154	#ifndef prompt	167	#ifndef prompt
155	# define prompt "ts> "	168	# define prompt "ts> "
156	#endif	169	#endif
157		170
…		…
236	is_vector (pointer p)	249	is_vector (pointer p)
237	{	250	{
238	return type (p) == T_VECTOR;	251	return type (p) == T_VECTOR;
239	}	252	}
240		253
		254	#define vecvalue(p) ((p)->object.vector.vvalue)
		255	#define veclength(p) ((p)->object.vector.length)
241	INTERFACE void fill_vector (pointer vec, pointer obj);	256	INTERFACE void fill_vector (pointer vec, pointer obj);
242	INTERFACE uint32_t vector_length (pointer vec);	257	INTERFACE uint32_t vector_length (pointer vec);
243	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);	258	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);	259	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245		260
…		…
314	{	329	{
315	return num_get_rvalue (p->object.number);	330	return num_get_rvalue (p->object.number);
316	}	331	}
317		332
318	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)	333	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319	#if USE_FLOAT	334	#if USE_REAL
320	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)	335	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321	# define set_num_integer(p) (p)->object.number.is_fixnum=1;	336	# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322	# define set_num_real(p) (p)->object.number.is_fixnum=0;	337	# define set_num_real(p) (p)->object.number.is_fixnum=0;
323	#else	338	#else
324	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	339	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
…		…
486	return type (p) == T_ENVIRONMENT;	501	return type (p) == T_ENVIRONMENT;
487	}	502	}
488		503
489	#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)	504	#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490		505
491	#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492	#define is_atom(p) (typeflag (p) & T_ATOM)	506	#define is_atom(p) (typeflag (p) & T_ATOM)
493	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)	507	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)
494	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	508	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495		509
496	#define is_mark(p) (typeflag (p) & T_MARK)	510	#define is_mark(p) (typeflag (p) & T_MARK)
497	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	511	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
498	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	512	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
499
500	#if 0
501	static int
502	is_atom(pointer p)
503	{
504	if (!is_atom1(p) != !is_atom2(p))
505	printf ("atoms disagree %x\n", typeflag(p));
506
507	return is_atom2(p);
508	}
509	#endif
510		513
511	INTERFACE INLINE int	514	INTERFACE INLINE int
512	is_immutable (pointer p)	515	is_immutable (pointer p)
513	{	516	{
514	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	517	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
618	static int file_push (SCHEME_P_ const char *fname);	621	static int file_push (SCHEME_P_ const char *fname);
619	static void file_pop (SCHEME_P);	622	static void file_pop (SCHEME_P);
620	static int file_interactive (SCHEME_P);	623	static int file_interactive (SCHEME_P);
621	static INLINE int is_one_of (char *s, int c);	624	static INLINE int is_one_of (char *s, int c);
622	static int alloc_cellseg (SCHEME_P_ int n);	625	static int alloc_cellseg (SCHEME_P_ int n);
623	static long binary_decode (const char *s);
624	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	626	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
625	static void finalize_cell (SCHEME_P_ pointer a);	627	static void finalize_cell (SCHEME_P_ pointer a);
626	static int count_consecutive_cells (pointer x, int needed);	628	static int count_consecutive_cells (pointer x, int needed);
627	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	629	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
628	static pointer mk_number (SCHEME_P_ const num n);	630	static pointer mk_number (SCHEME_P_ const num n);
…		…
875	#endif	877	#endif
876		878
877	static int	879	static int
878	is_zero_rvalue (RVALUE x)	880	is_zero_rvalue (RVALUE x)
879	{	881	{
880	#if USE_FLOAT	882	#if USE_REAL
881	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	883	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
882	#else	884	#else
883	return x == 0;	885	return x == 0;
884	#endif	886	#endif
885	}
886
887	static long
888	binary_decode (const char *s)
889	{
890	long x = 0;
891
892	while (s != 0 && (s == '1' \|\| *s == '0'))
893	{
894	x <<= 1;
895	x += *s - '0';
896	s++;
897	}
898
899	return x;
900	}	887	}
901		888
902	/* allocate new cell segment */	889	/* allocate new cell segment */
903	static int	890	static int
904	alloc_cellseg (SCHEME_P_ int n)	891	alloc_cellseg (SCHEME_P_ int n)
…		…
1132		1119
1133	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);	1120	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134	set_typeflag (x, T_SYMBOL);	1121	set_typeflag (x, T_SYMBOL);
1135	setimmutable (car (x));	1122	setimmutable (car (x));
1136		1123
1137	location = hash_fn (name, vector_length (SCHEME_V->oblist));	1124	location = hash_fn (name, veclength (SCHEME_V->oblist));
1138	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));	1125	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1139	return x;	1126	return x;
1140	}	1127	}
1141		1128
1142	static INLINE pointer	1129	static INLINE pointer
…		…
1144	{	1131	{
1145	int location;	1132	int location;
1146	pointer x;	1133	pointer x;
1147	char *s;	1134	char *s;
1148		1135
1149	location = hash_fn (name, vector_length (SCHEME_V->oblist));	1136	location = hash_fn (name, veclength (SCHEME_V->oblist));
1150		1137
1151	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1138	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1152	{	1139	{
1153	s = symname (car (x));	1140	s = symname (car (x));
1154		1141
…		…
1165	{	1152	{
1166	int i;	1153	int i;
1167	pointer x;	1154	pointer x;
1168	pointer ob_list = NIL;	1155	pointer ob_list = NIL;
1169		1156
1170	for (i = 0; i < vector_length (SCHEME_V->oblist); i++)	1157	for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1158	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1172	ob_list = cons (x, ob_list);	1159	ob_list = cons (x, ob_list);
1173		1160
1174	return ob_list;	1161	return ob_list;
1175	}	1162	}
…		…
1317	}	1304	}
1318		1305
1319	return q;	1306	return q;
1320	}	1307	}
1321		1308
1322	/* get new string */
1323	INTERFACE pointer	1309	INTERFACE pointer
1324	mk_string (SCHEME_P_ const char *str)	1310	mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1325	{	1311	{
1326	return mk_counted_string (SCHEME_A_ str, strlen (str));	1312	pointer x = get_cell (SCHEME_A_ NIL, NIL);
		1313
		1314	set_typeflag (x, T_STRING \| T_ATOM);
		1315	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
		1316	strlength (x) = len;
		1317	return x;
1327	}	1318	}
1328		1319
1329	INTERFACE pointer	1320	INTERFACE pointer
1330	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)	1321	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331	{	1322	{
…		…
1336	strlength (x) = len;	1327	strlength (x) = len;
1337	return x;	1328	return x;
1338	}	1329	}
1339		1330
1340	INTERFACE pointer	1331	INTERFACE pointer
1341	mk_empty_string (SCHEME_P_ uint32_t len, char fill)	1332	mk_string (SCHEME_P_ const char *str)
1342	{	1333	{
1343	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1334	return mk_counted_string (SCHEME_A_ str, strlen (str));
1344
1345	set_typeflag (x, T_STRING \| T_ATOM);
1346	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1347	strlength (x) = len;
1348	return x;
1349	}	1335	}
1350		1336
1351	INTERFACE pointer	1337	INTERFACE pointer
1352	mk_vector (SCHEME_P_ uint32_t len)	1338	mk_vector (SCHEME_P_ uint32_t len)
1353	{	1339	{
…		…
1358	fill_vector (pointer vec, pointer obj)	1344	fill_vector (pointer vec, pointer obj)
1359	{	1345	{
1360	int i;	1346	int i;
1361		1347
1362	for (i = 0; i < vec->object.vector.length; i++)	1348	for (i = 0; i < vec->object.vector.length; i++)
1363	vec->object.vector.vvalue[i] = obj;	1349	vecvalue (vec)[i] = obj;
1364	}	1350	}
1365		1351
1366	INTERFACE pointer	1352	INTERFACE pointer
1367	vector_elem (pointer vec, uint32_t ielem)	1353	vector_elem (pointer vec, uint32_t ielem)
1368	{	1354	{
1369	return vec->object.vector.vvalue[ielem];	1355	return vecvalue(vec)[ielem];
1370	}	1356	}
1371		1357
1372	INTERFACE void	1358	INTERFACE void
1373	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1359	set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374	{	1360	{
1375	vec->object.vector.vvalue[ielem] = a;	1361	vecvalue(vec)[ielem] = a;
1376	}	1362	}
1377		1363
1378	/* get new symbol */	1364	/* get new symbol */
1379	INTERFACE pointer	1365	INTERFACE pointer
1380	mk_symbol (SCHEME_P_ const char *name)	1366	mk_symbol (SCHEME_P_ const char *name)
…		…
1390		1376
1391	INTERFACE pointer	1377	INTERFACE pointer
1392	gensym (SCHEME_P)	1378	gensym (SCHEME_P)
1393	{	1379	{
1394	pointer x;	1380	pointer x;
1395	char name[40];
1396		1381
1397	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)	1382	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398	{	1383	{
1399	strcpy (name, "gensym-");	1384	char name[40] = "gensym-";
1400	xnum (name + 7, SCHEME_V->gensym_cnt);	1385	xnum (name + 7, SCHEME_V->gensym_cnt);
1401		1386
1402	/* first check oblist */	1387	/* first check oblist */
1403	x = oblist_find_by_name (SCHEME_A_ name);	1388	x = oblist_find_by_name (SCHEME_A_ name);
1404		1389
1405	if (x != NIL)	1390	if (x == NIL)
1406	continue;
1407	else
1408	{	1391	{
1409	x = oblist_add_by_name (SCHEME_A_ name);	1392	x = oblist_add_by_name (SCHEME_A_ name);
1410	return x;	1393	return x;
1411	}	1394	}
1412	}	1395	}
…		…
1421	char c, *p;	1404	char c, *p;
1422	int has_dec_point = 0;	1405	int has_dec_point = 0;
1423	int has_fp_exp = 0;	1406	int has_fp_exp = 0;
1424		1407
1425	#if USE_COLON_HOOK	1408	#if USE_COLON_HOOK
1426
1427	if ((p = strstr (q, "::")) != 0)	1409	if ((p = strstr (q, "::")) != 0)
1428	{	1410	{
1429	*p = 0;	1411	*p = 0;
1430	return cons (SCHEME_V->COLON_HOOK,	1412	return cons (SCHEME_V->COLON_HOOK,
1431	cons (cons (SCHEME_V->QUOTE,	1413	cons (cons (SCHEME_V->QUOTE,
1432	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));	1414	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1433	}	1415	}
1434
1435	#endif	1416	#endif
1436		1417
1437	p = q;	1418	p = q;
1438	c = *p++;	1419	c = *p++;
1439		1420
…		…
1488		1469
1489	return mk_symbol (SCHEME_A_ strlwr (q));	1470	return mk_symbol (SCHEME_A_ strlwr (q));
1490	}	1471	}
1491	}	1472	}
1492		1473
1493	#if USE_FLOAT	1474	#if USE_REAL
1494	if (has_dec_point)	1475	if (has_dec_point)
1495	return mk_real (SCHEME_A_ atof (q));	1476	return mk_real (SCHEME_A_ atof (q));
1496	#endif	1477	#endif
1497		1478
1498	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1479	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
…		…
1507		1488
1508	if (!strcmp (name, "t"))	1489	if (!strcmp (name, "t"))
1509	return S_T;	1490	return S_T;
1510	else if (!strcmp (name, "f"))	1491	else if (!strcmp (name, "f"))
1511	return S_F;	1492	return S_F;
1512	else if (name == 'o') / #o (octal) */
1513	{
1514	x = strtol (name + 1, 0, 8);
1515	return mk_integer (SCHEME_A_ x);
1516	}
1517	else if (name == 'd') / #d (decimal) */
1518	{
1519	x = strtol (name + 1, 0, 10);
1520	return mk_integer (SCHEME_A_ x);
1521	}
1522	else if (name == 'x') / #x (hex) */
1523	{
1524	x = strtol (name + 1, 0, 16);
1525	return mk_integer (SCHEME_A_ x);
1526	}
1527	else if (name == 'b') / #b (binary) */
1528	{
1529	x = binary_decode (name + 1);
1530	return mk_integer (SCHEME_A_ x);
1531	}
1532	else if (name == '\\') / #\w (character) */	1493	else if (name == '\\') / #\w (character) */
1533	{	1494	{
1534	int c = 0;	1495	int c = 0;
1535		1496
1536	if (stricmp (name + 1, "space") == 0)	1497	if (stricmp (name + 1, "space") == 0)
…		…
1563	return NIL;	1524	return NIL;
1564		1525
1565	return mk_character (SCHEME_A_ c);	1526	return mk_character (SCHEME_A_ c);
1566	}	1527	}
1567	else	1528	else
		1529	{
		1530	/* identify base by string index */
		1531	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
		1532	char base = strchr (baseidx, name);
		1533
		1534	if (base)
		1535	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
		1536
1568	return NIL;	1537	return NIL;
		1538	}
1569	}	1539	}
1570		1540
1571	/* ========== garbage collector ========== */	1541	/* ========== garbage collector ========== */
1572		1542
1573	/*--	1543	/*--
…		…
1588	if (is_vector (p))	1558	if (is_vector (p))
1589	{	1559	{
1590	int i;	1560	int i;
1591		1561
1592	for (i = 0; i < p->object.vector.length; i++)	1562	for (i = 0; i < p->object.vector.length; i++)
1593	mark (p->object.vector.vvalue[i]);	1563	mark (vecvalue (p)[i]);
1594	}	1564	}
1595		1565
1596	if (is_atom (p))	1566	if (is_atom (p))
1597	goto E6;	1567	goto E6;
1598		1568
…		…
1719	finalize_cell (SCHEME_P_ pointer a)	1689	finalize_cell (SCHEME_P_ pointer a)
1720	{	1690	{
1721	if (is_string (a))	1691	if (is_string (a))
1722	free (strvalue (a));	1692	free (strvalue (a));
1723	else if (is_vector (a))	1693	else if (is_vector (a))
1724	free (a->object.vector.vvalue);	1694	free (vecvalue (a));
1725	#if USE_PORTS	1695	#if USE_PORTS
1726	else if (is_port (a))	1696	else if (is_port (a))
1727	{	1697	{
1728	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)	1698	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729	port_close (SCHEME_A_ a, port_input \| port_output);	1699	port_close (SCHEME_A_ a, port_input \| port_output);
…		…
2556		2526
2557	if (f <= 1 \|\| f == 10) /* f is the base for numbers if > 1 */	2527	if (f <= 1 \|\| f == 10) /* f is the base for numbers if > 1 */
2558	{	2528	{
2559	if (num_is_integer (l))	2529	if (num_is_integer (l))
2560	xnum (p, ivalue_unchecked (l));	2530	xnum (p, ivalue_unchecked (l));
2561	#if USE_FLOAT	2531	#if USE_REAL
2562	else	2532	else
2563	{	2533	{
2564	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2534	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565	/* r5rs says there must be a '.' (unless 'e'?) */	2535	/* r5rs says there must be a '.' (unless 'e'?) */
2566	f = strcspn (p, ".e");	2536	f = strcspn (p, ".e");
…		…
2904	{	2874	{
2905	pointer slot = immutable_cons (variable, value);	2875	pointer slot = immutable_cons (variable, value);
2906		2876
2907	if (is_vector (car (env)))	2877	if (is_vector (car (env)))
2908	{	2878	{
2909	int location = hash_fn (symname (variable), vector_length (car (env)));	2879	int location = hash_fn (symname (variable), veclength (car (env)));
2910		2880
2911	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2881	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2912	}	2882	}
2913	else	2883	else
2914	set_car (env, immutable_cons (slot, car (env)));	2884	set_car (env, immutable_cons (slot, car (env)));
…		…
2922		2892
2923	for (x = env; x != NIL; x = cdr (x))	2893	for (x = env; x != NIL; x = cdr (x))
2924	{	2894	{
2925	if (is_vector (car (x)))	2895	if (is_vector (car (x)))
2926	{	2896	{
2927	location = hash_fn (symname (hdl), vector_length (car (x)));	2897	location = hash_fn (symname (hdl), veclength (car (x)));
2928	y = vector_elem (car (x), location);	2898	y = vector_elem (car (x), location);
2929	}	2899	}
2930	else	2900	else
2931	y = car (x);	2901	y = car (x);
2932		2902
…		…
3042	#if USE_ERROR_HOOK	3012	#if USE_ERROR_HOOK
3043	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);	3013	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044		3014
3045	if (x != NIL)	3015	if (x != NIL)
3046	{	3016	{
3047	if (a)	3017	pointer code = a
3048	SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL);	3018	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049	else	3019	: NIL;
3050	SCHEME_V->code = NIL;
3051		3020
3052	SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code);	3021	code = cons (mk_string (SCHEME_A_ s), code);
3053	setimmutable (car (SCHEME_V->code));	3022	setimmutable (car (code));
3054	SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code);	3023	SCHEME_V->code = cons (slot_value_in_env (x), code);
3055	SCHEME_V->op = OP_EVAL;	3024	SCHEME_V->op = OP_EVAL;
3056		3025
3057	return S_T;	3026	return S_T;
3058	}	3027	}
3059	#endif	3028	#endif
…		…
3350	s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);	3319	s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351	s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);	3320	s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352	s_goto (OP_READ_INTERNAL);	3321	s_goto (OP_READ_INTERNAL);
3353		3322
3354	case OP_T1LVL: /* top level */	3323	case OP_T1LVL: /* top level */
3355	SCHEME_V->code = SCHEME_V->value;	3324	SCHEME_V->code = SCHEME_V->value;
3356	SCHEME_V->inport = SCHEME_V->save_inport;	3325	SCHEME_V->inport = SCHEME_V->save_inport;
3357	s_goto (OP_EVAL);	3326	s_goto (OP_EVAL);
3358		3327
3359	case OP_READ_INTERNAL: /* internal read */	3328	case OP_READ_INTERNAL: /* internal read */
3360	SCHEME_V->tok = token (SCHEME_A);	3329	SCHEME_V->tok = token (SCHEME_A);
…		…
3410	else	3379	else
3411	Error_1 ("eval: unbound variable:", SCHEME_V->code);	3380	Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412	}	3381	}
3413	else if (is_pair (SCHEME_V->code))	3382	else if (is_pair (SCHEME_V->code))
3414	{	3383	{
		3384	x = car (SCHEME_V->code);
		3385
3415	if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */	3386	if (is_syntax (x)) /* SYNTAX */
3416	{	3387	{
3417	SCHEME_V->code = cdr (SCHEME_V->code);	3388	SCHEME_V->code = cdr (SCHEME_V->code);
3418	s_goto (syntaxnum (x));	3389	s_goto (syntaxnum (x));
3419	}	3390	}
3420	else /* first, eval top element and eval arguments */	3391	else /* first, eval top element and eval arguments */
3421	{	3392	{
3422	s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);	3393	s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3423	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */	3394	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424	SCHEME_V->code = car (SCHEME_V->code);	3395	SCHEME_V->code = x;
3425	s_goto (OP_EVAL);	3396	s_goto (OP_EVAL);
3426	}	3397	}
3427	}	3398	}
3428	else	3399	else
3429	s_return (SCHEME_V->code);	3400	s_return (SCHEME_V->code);
…		…
3987	SCHEME_V->code = car (SCHEME_V->args);	3958	SCHEME_V->code = car (SCHEME_V->args);
3988	s_goto (OP_EVAL);	3959	s_goto (OP_EVAL);
3989		3960
3990	case OP_CONTINUATION: /* call-with-current-continuation */	3961	case OP_CONTINUATION: /* call-with-current-continuation */
3991	SCHEME_V->code = car (SCHEME_V->args);	3962	SCHEME_V->code = car (SCHEME_V->args);
3992	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL);	3963	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993	s_goto (OP_APPLY);	3964	s_goto (OP_APPLY);
3994	}	3965	}
3995		3966
3996	return S_T;	3967	return S_T;
3997	}	3968	}
…		…
4505		4476
4506	s_return (vec);	4477	s_return (vec);
4507	}	4478	}
4508		4479
4509	case OP_VECLEN: /* vector-length */	4480	case OP_VECLEN: /* vector-length */
4510	s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args))));	4481	s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511		4482
4512	case OP_VECREF: /* vector-ref */	4483	case OP_VECREF: /* vector-ref */
4513	{	4484	{
4514	int index;	4485	int index;
4515		4486
4516	index = ivalue (cadr (SCHEME_V->args));	4487	index = ivalue (cadr (SCHEME_V->args));
4517		4488
4518	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4489	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));	4490	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520		4491
4521	s_return (vector_elem (car (SCHEME_V->args), index));	4492	s_return (vector_elem (car (SCHEME_V->args), index));
4522	}	4493	}
4523		4494
…		…
4528	if (is_immutable (car (SCHEME_V->args)))	4499	if (is_immutable (car (SCHEME_V->args)))
4529	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));	4500	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4530		4501
4531	index = ivalue (cadr (SCHEME_V->args));	4502	index = ivalue (cadr (SCHEME_V->args));
4532		4503
4533	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4504	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));	4505	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535		4506
4536	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));	4507	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4537	s_return (car (SCHEME_V->args));	4508	s_return (car (SCHEME_V->args));
4538	}	4509	}
…		…
5381		5352
5382	case OP_PVECFROM:	5353	case OP_PVECFROM:
5383	{	5354	{
5384	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5355	int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385	pointer vec = car (SCHEME_V->args);	5356	pointer vec = car (SCHEME_V->args);
5386	int len = vector_length (vec);	5357	int len = veclength (vec);
5387		5358
5388	if (i == len)	5359	if (i == len)
5389	{	5360	{
5390	putstr (SCHEME_A_ ")");	5361	putstr (SCHEME_A_ ")");
5391	s_return (S_T);	5362	s_return (S_T);
…		…
5815	set_cdr (S_T, S_T);	5786	set_cdr (S_T, S_T);
5816	/* init F */	5787	/* init F */
5817	set_typeflag (S_F, T_ATOM \| T_MARK);	5788	set_typeflag (S_F, T_ATOM \| T_MARK);
5818	set_car (S_F, S_F);	5789	set_car (S_F, S_F);
5819	set_cdr (S_F, S_F);	5790	set_cdr (S_F, S_F);
		5791	/* init EOF_OBJ */
		5792	set_typeflag (S_EOF, T_ATOM \| T_MARK);
		5793	set_car (S_EOF, S_EOF);
		5794	set_cdr (S_EOF, S_EOF);
5820	/* init sink */	5795	/* init sink */
5821	set_typeflag (S_SINK, T_PAIR \| T_MARK);	5796	set_typeflag (S_SINK, T_PAIR \| T_MARK);
5822	set_car (S_SINK, NIL);	5797	set_car (S_SINK, NIL);
		5798
5823	/* init c_nest */	5799	/* init c_nest */
5824	SCHEME_V->c_nest = NIL;	5800	SCHEME_V->c_nest = NIL;
5825		5801
5826	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	5802	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5827	/* init global_env */	5803	/* init global_env */
…		…
6110		6086
6111	/* ========== Main ========== */	6087	/* ========== Main ========== */
6112		6088
6113	#if STANDALONE	6089	#if STANDALONE
6114		6090
6115	# if defined(__APPLE__) && !defined (OSX)
6116	int
6117	main ()
6118	{
6119	extern MacTS_main (int argc, char **argv);
6120	char **argv;
6121	int argc = ccommand (&argv);
6122
6123	MacTS_main (argc, argv);
6124	return 0;
6125	}
6126
6127	int
6128	MacTS_main (int argc, char **argv)
6129	{
6130	# else
6131	int	6091	int
6132	main (int argc, char **argv)	6092	main (int argc, char **argv)
6133	{	6093	{
6134	# endif
6135	# if USE_MULTIPLICITY	6094	# if USE_MULTIPLICITY
6136	scheme ssc;	6095	scheme ssc;
6137	scheme *const SCHEME_V = &ssc;	6096	scheme *const SCHEME_V = &ssc;
6138	# else	6097	# else
6139	# endif	6098	# endif

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.6 by root, Wed Nov 25 10:57:17 2015 UTC vs. Revision 1.8 by root, Wed Nov 25 22:36:25 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.6 by root, Wed Nov 25 10:57:17 2015 UTC vs.
Revision 1.8 by root, Wed Nov 25 22:36:25 2015 UTC