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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.7 by root, Wed Nov 25 22:12:59 2015 UTC vs.
Revision 1.13 by root, Thu Nov 26 07:59:42 2015 UTC

…		…
65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67	#define S_SINK (&SCHEME_V->xsink)	67	#define S_SINK (&SCHEME_V->xsink)
68	#define S_EOF (&SCHEME_V->xEOF_OBJ)	68	#define S_EOF (&SCHEME_V->xEOF_OBJ)
69		69
		70	/* should use libecb */
		71	#if __GNUC__ >= 4
		72	# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
		73	# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
		74	# define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
		75	#endif
		76
70	#if !USE_MULTIPLICITY	77	#if !USE_MULTIPLICITY
71	static scheme sc;	78	static scheme sc;
72	#endif	79	#endif
73		80
74	static void	81	static void
…		…
201	#define T_SYNTAX 0x0010	208	#define T_SYNTAX 0x0010
202	#define T_IMMUTABLE 0x0020	209	#define T_IMMUTABLE 0x0020
203	#define T_ATOM 0x0040 /* only for gc */	210	#define T_ATOM 0x0040 /* only for gc */
204	#define T_MARK 0x0080 /* only for gc */	211	#define T_MARK 0x0080 /* only for gc */
205		212
206	static num num_add (num a, num b);
207	static num num_mul (num a, num b);	213	static num num_op (char op, num a, num b);
208	static num num_div (num a, num b);
209	static num num_intdiv (num a, num b);	214	static num num_intdiv (num a, num b);
210	static num num_sub (num a, num b);
211	static num num_rem (num a, num b);	215	static num num_rem (num a, num b);
212	static num num_mod (num a, num b);	216	static num num_mod (num a, num b);
213	static int num_eq (num a, num b);	217	static int num_eq (num a, num b);
214	static int num_gt (num a, num b);	218	static int num_gt (num a, num b);
215	static int num_ge (num a, num b);	219	static int num_ge (num a, num b);
…		…
369	{	373	{
370	return type (p) == T_PAIR;	374	return type (p) == T_PAIR;
371	}	375	}
372		376
373	#define car(p) ((p)->object.cons.car + 0)	377	#define car(p) ((p)->object.cons.car + 0)
374	#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */	378	#define cdr(p) ((p)->object.cons.cdr + 0)
375		379
376	#define caar(p) car (car (p))	380	static pointer caar (pointer p) { return car (car (p)); }
377	#define cadr(p) car (cdr (p))	381	static pointer cadr (pointer p) { return car (cdr (p)); }
378	#define cdar(p) cdr (car (p))	382	static pointer cdar (pointer p) { return cdr (car (p)); }
379	#define cddr(p) cdr (cdr (p))	383	static pointer cddr (pointer p) { return cdr (cdr (p)); }
380		384
381	#define cadar(p) car (cdr (car (p)))	385	static pointer cadar (pointer p) { return car (cdr (car (p))); }
382	#define caddr(p) car (cdr (cdr (p)))	386	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
383	#define cdaar(p) cdr (car (car (p)))	387	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
384		388
385	INTERFACE void	389	INTERFACE void
386	set_car (pointer p, pointer q)	390	set_car (pointer p, pointer q)
387	{	391	{
388	p->object.cons.car = q;	392	p->object.cons.car = q;
…		…
621	static int file_push (SCHEME_P_ const char *fname);	625	static int file_push (SCHEME_P_ const char *fname);
622	static void file_pop (SCHEME_P);	626	static void file_pop (SCHEME_P);
623	static int file_interactive (SCHEME_P);	627	static int file_interactive (SCHEME_P);
624	static INLINE int is_one_of (char *s, int c);	628	static INLINE int is_one_of (char *s, int c);
625	static int alloc_cellseg (SCHEME_P_ int n);	629	static int alloc_cellseg (SCHEME_P_ int n);
626	static long binary_decode (const char *s);
627	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	630	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
628	static void finalize_cell (SCHEME_P_ pointer a);	631	static void finalize_cell (SCHEME_P_ pointer a);
629	static int count_consecutive_cells (pointer x, int needed);	632	static int count_consecutive_cells (pointer x, int needed);
630	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	633	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
631	static pointer mk_number (SCHEME_P_ const num n);	634	static pointer mk_number (SCHEME_P_ const num n);
…		…
675	static void assign_syntax (SCHEME_P_ const char *name);	678	static void assign_syntax (SCHEME_P_ const char *name);
676	static int syntaxnum (pointer p);	679	static int syntaxnum (pointer p);
677	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	680	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
678		681
679	static num	682	static num
680	num_add (num a, num b)	683	num_op (char op, num a, num b)
681	{	684	{
682	num ret;	685	num ret;
683		686
684	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	687	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
685		688
686	if (num_is_fixnum (ret))	689	if (num_is_fixnum (ret))
687	num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b));	690	{
		691	IVALUE av = num_get_ivalue (a);
		692	IVALUE bv = num_get_ivalue (b);
		693
		694	switch (op)
		695	{
		696	case '+': av += bv; break;
		697	case '-': av -= bv; break;
		698	case '': av = bv; break;
		699	case '/': av /= bv; break;
		700	}
		701
		702	num_set_ivalue (ret, av);
		703	}
688	else	704	else
689	num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b));	705	{
		706	RVALUE av = num_get_rvalue (a);
		707	RVALUE bv = num_get_rvalue (b);
690		708
691	return ret;	709	switch (op)
692	}	710	{
		711	case '+': av += bv; break;
		712	case '-': av -= bv; break;
		713	case '': av = bv; break;
		714	case '/': av /= bv; break;
		715	}
693		716
694	static num	717	num_set_rvalue (ret, av);
695	num_mul (num a, num b)	718	}
696	{
697	num ret;
698
699	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
700
701	if (num_is_fixnum (ret))
702	num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
703	else
704	num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
705		719
706	return ret;	720	return ret;
707	}	721	}
708		722
709	static num	723	static num
…		…
715		729
716	if (num_is_fixnum (ret))	730	if (num_is_fixnum (ret))
717	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));	731	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
718	else	732	else
719	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));	733	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
720
721	return ret;
722	}
723
724	static num
725	num_intdiv (num a, num b)
726	{
727	num ret;
728
729	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
730
731	if (num_is_fixnum (ret))
732	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
733	else
734	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
735
736	return ret;
737	}
738
739	static num
740	num_sub (num a, num b)
741	{
742	num ret;
743
744	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
745
746	if (num_is_fixnum (ret))
747	num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
748	else
749	num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
750		734
751	return ret;	735	return ret;
752	}	736	}
753		737
754	static num	738	static num
…		…
883	#if USE_REAL	867	#if USE_REAL
884	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	868	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
885	#else	869	#else
886	return x == 0;	870	return x == 0;
887	#endif	871	#endif
888	}
889
890	static long
891	binary_decode (const char *s)
892	{
893	long x = 0;
894
895	while (s != 0 && (s == '1' \|\| *s == '0'))
896	{
897	x <<= 1;
898	x += *s - '0';
899	s++;
900	}
901
902	return x;
903	}	872	}
904		873
905	/* allocate new cell segment */	874	/* allocate new cell segment */
906	static int	875	static int
907	alloc_cellseg (SCHEME_P_ int n)	876	alloc_cellseg (SCHEME_P_ int n)
…		…
981		950
982	/* get new cell. parameter a, b is marked by gc. */	951	/* get new cell. parameter a, b is marked by gc. */
983	static INLINE pointer	952	static INLINE pointer
984	get_cell_x (SCHEME_P_ pointer a, pointer b)	953	get_cell_x (SCHEME_P_ pointer a, pointer b)
985	{	954	{
986	if (SCHEME_V->free_cell == NIL)	955	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
987	{	956	{
988	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	957	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
989	return S_SINK;	958	return S_SINK;
990		959
991	if (SCHEME_V->free_cell == NIL)	960	if (SCHEME_V->free_cell == NIL)
…		…
1320	}	1289	}
1321		1290
1322	return q;	1291	return q;
1323	}	1292	}
1324		1293
1325	/* get new string */
1326	INTERFACE pointer	1294	INTERFACE pointer
1327	mk_string (SCHEME_P_ const char *str)	1295	mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1328	{	1296	{
1329	return mk_counted_string (SCHEME_A_ str, strlen (str));	1297	pointer x = get_cell (SCHEME_A_ NIL, NIL);
		1298
		1299	set_typeflag (x, T_STRING \| T_ATOM);
		1300	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
		1301	strlength (x) = len;
		1302	return x;
1330	}	1303	}
1331		1304
1332	INTERFACE pointer	1305	INTERFACE pointer
1333	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)	1306	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1334	{	1307	{
…		…
1339	strlength (x) = len;	1312	strlength (x) = len;
1340	return x;	1313	return x;
1341	}	1314	}
1342		1315
1343	INTERFACE pointer	1316	INTERFACE pointer
1344	mk_empty_string (SCHEME_P_ uint32_t len, char fill)	1317	mk_string (SCHEME_P_ const char *str)
1345	{	1318	{
1346	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1319	return mk_counted_string (SCHEME_A_ str, strlen (str));
1347
1348	set_typeflag (x, T_STRING \| T_ATOM);
1349	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1350	strlength (x) = len;
1351	return x;
1352	}	1320	}
1353		1321
1354	INTERFACE pointer	1322	INTERFACE pointer
1355	mk_vector (SCHEME_P_ uint32_t len)	1323	mk_vector (SCHEME_P_ uint32_t len)
1356	{	1324	{
…		…
1393		1361
1394	INTERFACE pointer	1362	INTERFACE pointer
1395	gensym (SCHEME_P)	1363	gensym (SCHEME_P)
1396	{	1364	{
1397	pointer x;	1365	pointer x;
1398	char name[40];
1399		1366
1400	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)	1367	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1401	{	1368	{
1402	strcpy (name, "gensym-");	1369	char name[40] = "gensym-";
1403	xnum (name + 7, SCHEME_V->gensym_cnt);	1370	xnum (name + 7, SCHEME_V->gensym_cnt);
1404		1371
1405	/* first check oblist */	1372	/* first check oblist */
1406	x = oblist_find_by_name (SCHEME_A_ name);	1373	x = oblist_find_by_name (SCHEME_A_ name);
1407		1374
1408	if (x != NIL)	1375	if (x == NIL)
1409	continue;
1410	else
1411	{	1376	{
1412	x = oblist_add_by_name (SCHEME_A_ name);	1377	x = oblist_add_by_name (SCHEME_A_ name);
1413	return x;	1378	return x;
1414	}	1379	}
1415	}	1380	}
…		…
1424	char c, *p;	1389	char c, *p;
1425	int has_dec_point = 0;	1390	int has_dec_point = 0;
1426	int has_fp_exp = 0;	1391	int has_fp_exp = 0;
1427		1392
1428	#if USE_COLON_HOOK	1393	#if USE_COLON_HOOK
1429
1430	if ((p = strstr (q, "::")) != 0)	1394	if ((p = strstr (q, "::")) != 0)
1431	{	1395	{
1432	*p = 0;	1396	*p = 0;
1433	return cons (SCHEME_V->COLON_HOOK,	1397	return cons (SCHEME_V->COLON_HOOK,
1434	cons (cons (SCHEME_V->QUOTE,	1398	cons (cons (SCHEME_V->QUOTE,
1435	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));	1399	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1436	}	1400	}
1437
1438	#endif	1401	#endif
1439		1402
1440	p = q;	1403	p = q;
1441	c = *p++;	1404	c = *p++;
1442		1405
…		…
1503		1466
1504	/* make constant */	1467	/* make constant */
1505	static pointer	1468	static pointer
1506	mk_sharp_const (SCHEME_P_ char *name)	1469	mk_sharp_const (SCHEME_P_ char *name)
1507	{	1470	{
1508	long x;
1509	char tmp[STRBUFFSIZE];
1510
1511	if (!strcmp (name, "t"))	1471	if (!strcmp (name, "t"))
1512	return S_T;	1472	return S_T;
1513	else if (!strcmp (name, "f"))	1473	else if (!strcmp (name, "f"))
1514	return S_F;	1474	return S_F;
1515	else if (name == 'o') / #o (octal) */
1516	{
1517	x = strtol (name + 1, 0, 8);
1518	return mk_integer (SCHEME_A_ x);
1519	}
1520	else if (name == 'd') / #d (decimal) */
1521	{
1522	x = strtol (name + 1, 0, 10);
1523	return mk_integer (SCHEME_A_ x);
1524	}
1525	else if (name == 'x') / #x (hex) */
1526	{
1527	x = strtol (name + 1, 0, 16);
1528	return mk_integer (SCHEME_A_ x);
1529	}
1530	else if (name == 'b') / #b (binary) */
1531	{
1532	x = binary_decode (name + 1);
1533	return mk_integer (SCHEME_A_ x);
1534	}
1535	else if (name == '\\') / #\w (character) */	1475	else if (name == '\\') / #\w (character) */
1536	{	1476	{
1537	int c = 0;	1477	int c;
1538		1478
1539	if (stricmp (name + 1, "space") == 0)	1479	if (stricmp (name + 1, "space") == 0)
1540	c = ' ';	1480	c = ' ';
1541	else if (stricmp (name + 1, "newline") == 0)	1481	else if (stricmp (name + 1, "newline") == 0)
1542	c = '\n';	1482	c = '\n';
…		…
1544	c = '\r';	1484	c = '\r';
1545	else if (stricmp (name + 1, "tab") == 0)	1485	else if (stricmp (name + 1, "tab") == 0)
1546	c = '\t';	1486	c = '\t';
1547	else if (name[1] == 'x' && name[2] != 0)	1487	else if (name[1] == 'x' && name[2] != 0)
1548	{	1488	{
1549	int c1 = strtol (name + 2, 0, 16);	1489	long c1 = strtol (name + 2, 0, 16);
1550		1490
1551	if (c1 <= UCHAR_MAX)	1491	if (0 <= c1 && c1 <= UCHAR_MAX)
1552	c = c1;	1492	c = c1;
1553	else	1493	else
1554	return NIL;	1494	return NIL;
1555		1495	}
1556	#if USE_ASCII_NAMES	1496	#if USE_ASCII_NAMES
1557	}
1558	else if (is_ascii_name (name + 1, &c))	1497	else if (is_ascii_name (name + 1, &c))
1559	{
1560	/* nothing */	1498	/* nothing */;
1561	#endif	1499	#endif
1562	}
1563	else if (name[2] == 0)	1500	else if (name[2] == 0)
1564	c = name[1];	1501	c = name[1];
1565	else	1502	else
1566	return NIL;	1503	return NIL;
1567		1504
1568	return mk_character (SCHEME_A_ c);	1505	return mk_character (SCHEME_A_ c);
1569	}	1506	}
1570	else	1507	else
		1508	{
		1509	/* identify base by string index */
		1510	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
		1511	char base = strchr (baseidx, name);
		1512
		1513	if (base)
		1514	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
		1515
1571	return NIL;	1516	return NIL;
		1517	}
1572	}	1518	}
1573		1519
1574	/* ========== garbage collector ========== */	1520	/* ========== garbage collector ========== */
1575		1521
1576	/*--	1522	/*--
1577	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,	1523	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1578	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1524	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1579	* for marking.	1525	* for marking.
		1526	*
		1527	* The exception is vectors - vectors are currently marked recursively,
		1528	* which is inherited form tinyscheme and could be fixed by having another
		1529	* word of context in the vector
1580	*/	1530	*/
1581	static void	1531	static void
1582	mark (pointer a)	1532	mark (pointer a)
1583	{	1533	{
1584	pointer t, q, p;	1534	pointer t, q, p;
…		…
1586	t = 0;	1536	t = 0;
1587	p = a;	1537	p = a;
1588	E2:	1538	E2:
1589	setmark (p);	1539	setmark (p);
1590		1540
1591	if (is_vector (p))	1541	if (ecb_expect_false (is_vector (p)))
1592	{	1542	{
1593	int i;	1543	int i;
1594		1544
1595	for (i = 0; i < p->object.vector.length; i++)	1545	for (i = 0; i < p->object.vector.length; i++)
1596	mark (vecvalue (p)[i]);	1546	mark (vecvalue (p)[i]);
…		…
1719	}	1669	}
1720		1670
1721	static void	1671	static void
1722	finalize_cell (SCHEME_P_ pointer a)	1672	finalize_cell (SCHEME_P_ pointer a)
1723	{	1673	{
		1674	/* TODO, fast bitmap check? */
1724	if (is_string (a))	1675	if (is_string (a))
1725	free (strvalue (a));	1676	free (strvalue (a));
1726	else if (is_vector (a))	1677	else if (is_vector (a))
1727	free (vecvalue (a));	1678	free (vecvalue (a));
1728	#if USE_PORTS	1679	#if USE_PORTS
…		…
4134		4085
4135	case OP_ADD: /* + */	4086	case OP_ADD: /* + */
4136	v = num_zero;	4087	v = num_zero;
4137		4088
4138	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4089	for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4139	v = num_add (v, nvalue (car (x)));	4090	v = num_op ('+', v, nvalue (car (x)));
4140		4091
4141	s_return (mk_number (SCHEME_A_ v));	4092	s_return (mk_number (SCHEME_A_ v));
4142		4093
4143	case OP_MUL: /* * */	4094	case OP_MUL: /* * */
4144	v = num_one;	4095	v = num_one;
4145		4096
4146	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4097	for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4147	v = num_mul (v, nvalue (car (x)));	4098	v = num_op ('+', v, nvalue (car (x)));
4148		4099
4149	s_return (mk_number (SCHEME_A_ v));	4100	s_return (mk_number (SCHEME_A_ v));
4150		4101
4151	case OP_SUB: /* - */	4102	case OP_SUB: /* - */
4152	if (cdr (SCHEME_V->args) == NIL)	4103	if (cdr (SCHEME_V->args) == NIL)
…		…
4159	x = cdr (SCHEME_V->args);	4110	x = cdr (SCHEME_V->args);
4160	v = nvalue (car (SCHEME_V->args));	4111	v = nvalue (car (SCHEME_V->args));
4161	}	4112	}
4162		4113
4163	for (; x != NIL; x = cdr (x))	4114	for (; x != NIL; x = cdr (x))
4164	v = num_sub (v, nvalue (car (x)));	4115	v = num_op ('+', v, nvalue (car (x)));
4165		4116
4166	s_return (mk_number (SCHEME_A_ v));	4117	s_return (mk_number (SCHEME_A_ v));
4167		4118
4168	case OP_DIV: /* / */	4119	case OP_DIV: /* / */
4169	if (cdr (SCHEME_V->args) == NIL)	4120	if (cdr (SCHEME_V->args) == NIL)
…		…
4200	}	4151	}
4201		4152
4202	for (; x != NIL; x = cdr (x))	4153	for (; x != NIL; x = cdr (x))
4203	{	4154	{
4204	if (ivalue (car (x)) != 0)	4155	if (ivalue (car (x)) != 0)
4205	v = num_intdiv (v, nvalue (car (x)));	4156	v = num_op ('/', v, nvalue (car (x)));
4206	else	4157	else
4207	Error_0 ("quotient: division by zero");	4158	Error_0 ("quotient: division by zero");
4208	}	4159	}
4209		4160
4210	s_return (mk_number (SCHEME_A_ v));	4161	s_return (mk_number (SCHEME_A_ v));
…		…
5574	int ok = 1;	5525	int ok = 1;
5575	char msg[STRBUFFSIZE];	5526	char msg[STRBUFFSIZE];
5576	int n = list_length (SCHEME_A_ SCHEME_V->args);	5527	int n = list_length (SCHEME_A_ SCHEME_V->args);
5577		5528
5578	/* Check number of arguments */	5529	/* Check number of arguments */
5579	if (n < pcd->min_arity)	5530	if (ecb_expect_false (n < pcd->min_arity))
5580	{	5531	{
5581	ok = 0;	5532	ok = 0;
5582	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5533	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5583	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5534	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5584	}	5535	}
5585		5536	else if (ecb_excpect_false (n > pcd->max_arity))
5586	if (ok && n > pcd->max_arity)
5587	{	5537	{
5588	ok = 0;	5538	ok = 0;
5589	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5539	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5590	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5540	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5591	}	5541	}
5592		5542
5593	if (ok)	5543	if (ecb_expect_false (ok))
5594	{	5544	{
5595	if (pcd->arg_tests_encoding)	5545	if (pcd->arg_tests_encoding)
5596	{	5546	{
5597	int i = 0;	5547	int i = 0;
5598	int j;	5548	int j;
…		…
5642	}	5592	}
5643	#endif	5593	#endif
5644		5594
5645	ok_to_freely_gc (SCHEME_A);	5595	ok_to_freely_gc (SCHEME_A);
5646		5596
5647	if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)	5597	if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5648	return;	5598	return;
5649		5599
5650	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5600	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5651	{	5601	{
5652	xwrstr ("No memory!\n");	5602	xwrstr ("No memory!\n");
…		…
5710		5660
5711	case 'd':	5661	case 'd':
5712	return OP_COND0; /* cond */	5662	return OP_COND0; /* cond */
5713		5663
5714	case '*':	5664	case '*':
5715	return OP_LET0AST; /* let* */	5665	return OP_LET0AST;/* let* */
5716		5666
5717	default:	5667	default:
5718	return OP_SET0; /* set! */	5668	return OP_SET0; /* set! */
5719	}	5669	}
5720		5670
…		…
5742		5692
5743	case 'f':	5693	case 'f':
5744	return OP_DEF0; /* define */	5694	return OP_DEF0; /* define */
5745		5695
5746	default:	5696	default:
5747	return OP_LET0REC; /* letrec */	5697	return OP_LET0REC;/* letrec */
5748	}	5698	}
5749		5699
5750	default:	5700	default:
5751	return OP_C0STREAM; /* cons-stream */	5701	return OP_C0STREAM; /* cons-stream */
5752	}	5702	}

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.7 by root, Wed Nov 25 22:12:59 2015 UTC vs. Revision 1.13 by root, Thu Nov 26 07:59:42 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.7 by root, Wed Nov 25 22:12:59 2015 UTC vs.
Revision 1.13 by root, Thu Nov 26 07:59:42 2015 UTC