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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.4 by root, Wed Nov 25 10:49:29 2015 UTC vs.
Revision 1.15 by root, Thu Nov 26 09:05:20 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.
60	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
61	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
62	#define S_SINK (&SCHEME_V->xsink)	67	#define S_SINK (&SCHEME_V->xsink)
63	#define S_EOF (&SCHEME_V->xEOF_OBJ)	68	#define S_EOF (&SCHEME_V->xEOF_OBJ)
64		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
65	#if !USE_MULTIPLICITY	77	#if !USE_MULTIPLICITY
66	static scheme sc;	78	static scheme sc;
67	#endif	79	#endif
68		80
69	static void	81	static void
…		…
128	c += 'a' - 'A';	140	c += 'a' - 'A';
129		141
130	return c;	142	return c;
131	}	143	}
132		144
		145	static int
		146	xisdigit (char c)
		147	{
		148	return c >= '0' && c <= '9';
		149	}
		150
		151	#define toupper(c) xtoupper (c)
		152	#define tolower(c) xtolower (c)
		153	#define isdigit(c) xisdigit (c)
		154
133	#if USE_STRLWR	155	#if USE_STRLWR
134	static const char *	156	static const char *
135	strlwr (char *s)	157	strlwr (char *s)
136	{	158	{
137	const char *p = s;	159	const char *p = s;
…		…
146	}	168	}
147	#endif	169	#endif
148		170
149	#define stricmp(a,b) strcmp (a, b)	171	#define stricmp(a,b) strcmp (a, b)
150	#define strlwr(s) (s)	172	#define strlwr(s) (s)
151	#define toupper(c) xtoupper(c)
152	#define tolower(c) xtolower(c)
153		173
154	#ifndef prompt	174	#ifndef prompt
155	# define prompt "ts> "	175	# define prompt "ts> "
156	#endif	176	#endif
157		177
…		…
188	#define T_SYNTAX 0x0010	208	#define T_SYNTAX 0x0010
189	#define T_IMMUTABLE 0x0020	209	#define T_IMMUTABLE 0x0020
190	#define T_ATOM 0x0040 /* only for gc */	210	#define T_ATOM 0x0040 /* only for gc */
191	#define T_MARK 0x0080 /* only for gc */	211	#define T_MARK 0x0080 /* only for gc */
192		212
193	static num num_add (num a, num b);	213	enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
194	static num num_mul (num a, num b);	214
195	static num num_div (num a, num b);	215	static num num_op (enum num_op op, num a, num b);
196	static num num_intdiv (num a, num b);	216	static num num_intdiv (num a, num b);
197	static num num_sub (num a, num b);
198	static num num_rem (num a, num b);	217	static num num_rem (num a, num b);
199	static num num_mod (num a, num b);	218	static num num_mod (num a, num b);
200	static int num_eq (num a, num b);
201	static int num_gt (num a, num b);
202	static int num_ge (num a, num b);
203	static int num_lt (num a, num b);
204	static int num_le (num a, num b);
205		219
206	#if USE_MATH	220	#if USE_MATH
207	static double round_per_R5RS (double x);	221	static double round_per_R5RS (double x);
208	#endif	222	#endif
209	static int is_zero_rvalue (RVALUE x);	223	static int is_zero_rvalue (RVALUE x);
…		…
236	is_vector (pointer p)	250	is_vector (pointer p)
237	{	251	{
238	return type (p) == T_VECTOR;	252	return type (p) == T_VECTOR;
239	}	253	}
240		254
		255	#define vecvalue(p) ((p)->object.vector.vvalue)
		256	#define veclength(p) ((p)->object.vector.length)
241	INTERFACE void fill_vector (pointer vec, pointer obj);	257	INTERFACE void fill_vector (pointer vec, pointer obj);
242	INTERFACE uint32_t vector_length (pointer vec);	258	INTERFACE uint32_t vector_length (pointer vec);
243	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);	259	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);	260	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245		261
…		…
314	{	330	{
315	return num_get_rvalue (p->object.number);	331	return num_get_rvalue (p->object.number);
316	}	332	}
317		333
318	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)	334	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319	#if USE_FLOAT	335	#if USE_REAL
320	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)	336	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321	# define set_num_integer(p) (p)->object.number.is_fixnum=1;	337	# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322	# define set_num_real(p) (p)->object.number.is_fixnum=0;	338	# define set_num_real(p) (p)->object.number.is_fixnum=0;
323	#else	339	#else
324	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	340	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
…		…
354	{	370	{
355	return type (p) == T_PAIR;	371	return type (p) == T_PAIR;
356	}	372	}
357		373
358	#define car(p) ((p)->object.cons.car + 0)	374	#define car(p) ((p)->object.cons.car + 0)
359	#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */	375	#define cdr(p) ((p)->object.cons.cdr + 0)
360		376
361	#define caar(p) car (car (p))	377	static pointer caar (pointer p) { return car (car (p)); }
362	#define cadr(p) car (cdr (p))	378	static pointer cadr (pointer p) { return car (cdr (p)); }
363	#define cdar(p) cdr (car (p))	379	static pointer cdar (pointer p) { return cdr (car (p)); }
364	#define cddr(p) cdr (cdr (p))	380	static pointer cddr (pointer p) { return cdr (cdr (p)); }
365		381
366	#define cadar(p) car (cdr (car (p)))	382	static pointer cadar (pointer p) { return car (cdr (car (p))); }
367	#define caddr(p) car (cdr (cdr (p)))	383	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
368	#define cdaar(p) cdr (car (car (p)))	384	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
369		385
370	INTERFACE void	386	INTERFACE void
371	set_car (pointer p, pointer q)	387	set_car (pointer p, pointer q)
372	{	388	{
373	p->object.cons.car = q;	389	p->object.cons.car = q;
…		…
486	return type (p) == T_ENVIRONMENT;	502	return type (p) == T_ENVIRONMENT;
487	}	503	}
488		504
489	#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)	505	#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490		506
491	#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492	#define is_atom(p) (typeflag (p) & T_ATOM)	507	#define is_atom(p) (typeflag (p) & T_ATOM)
493	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)	508	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)
494	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	509	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495		510
496	#define is_mark(p) (typeflag (p) & T_MARK)	511	#define is_mark(p) (typeflag (p) & T_MARK)
497	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	512	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
498	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	513	#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		514
511	INTERFACE INLINE int	515	INTERFACE INLINE int
512	is_immutable (pointer p)	516	is_immutable (pointer p)
513	{	517	{
514	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	518	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
618	static int file_push (SCHEME_P_ const char *fname);	622	static int file_push (SCHEME_P_ const char *fname);
619	static void file_pop (SCHEME_P);	623	static void file_pop (SCHEME_P);
620	static int file_interactive (SCHEME_P);	624	static int file_interactive (SCHEME_P);
621	static INLINE int is_one_of (char *s, int c);	625	static INLINE int is_one_of (char *s, int c);
622	static int alloc_cellseg (SCHEME_P_ int n);	626	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);	627	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
625	static void finalize_cell (SCHEME_P_ pointer a);	628	static void finalize_cell (SCHEME_P_ pointer a);
626	static int count_consecutive_cells (pointer x, int needed);	629	static int count_consecutive_cells (pointer x, int needed);
627	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	630	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
628	static pointer mk_number (SCHEME_P_ const num n);	631	static pointer mk_number (SCHEME_P_ const num n);
…		…
662	static pointer ss_get_cont (SCHEME_P);	665	static pointer ss_get_cont (SCHEME_P);
663	static void ss_set_cont (SCHEME_P_ pointer cont);	666	static void ss_set_cont (SCHEME_P_ pointer cont);
664	static void dump_stack_mark (SCHEME_P);	667	static void dump_stack_mark (SCHEME_P);
665	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);	668	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
666	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	669	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);
		670	static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
667	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);	671	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
668	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	672	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
669	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	673	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
670	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	674	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
671	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	675	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
672	static void assign_syntax (SCHEME_P_ const char *name);	676	static void assign_syntax (SCHEME_P_ const char *name);
673	static int syntaxnum (pointer p);	677	static int syntaxnum (pointer p);
674	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	678	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
675		679
676	static num	680	static num
677	num_add (num a, num b)	681	num_op (enum num_op op, num a, num b)
678	{	682	{
679	num ret;	683	num ret;
680		684
681	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	685	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
682		686
683	if (num_is_fixnum (ret))	687	if (num_is_fixnum (ret))
684	num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b));	688	{
		689	IVALUE av = num_get_ivalue (a);
		690	IVALUE bv = num_get_ivalue (b);
		691
		692	switch (op)
		693	{
		694	case NUM_ADD: av += bv; break;
		695	case NUM_SUB: av -= bv; break;
		696	case NUM_MUL: av *= bv; break;
		697	case NUM_INTDIV: av /= bv; break;
		698	}
		699
		700	num_set_ivalue (ret, av);
		701	}
685	else	702	else
686	num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b));	703	{
		704	RVALUE av = num_get_rvalue (a);
		705	RVALUE bv = num_get_rvalue (b);
687		706
688	return ret;	707	switch (op)
689	}	708	{
		709	case NUM_ADD: av += bv; break;
		710	case NUM_SUB: av -= bv; break;
		711	case NUM_MUL: av *= bv; break;
		712	case NUM_INTDIV: av /= bv; break;
		713	}
690		714
691	static num	715	num_set_rvalue (ret, av);
692	num_mul (num a, num b)	716	}
693	{
694	num ret;
695
696	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
697
698	if (num_is_fixnum (ret))
699	num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
700	else
701	num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
702		717
703	return ret;	718	return ret;
704	}	719	}
705		720
706	static num	721	static num
…		…
717		732
718	return ret;	733	return ret;
719	}	734	}
720		735
721	static num	736	static num
722	num_intdiv (num a, num b)
723	{
724	num ret;
725
726	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
727
728	if (num_is_fixnum (ret))
729	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
730	else
731	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
732
733	return ret;
734	}
735
736	static num
737	num_sub (num a, num b)
738	{
739	num ret;
740
741	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
742
743	if (num_is_fixnum (ret))
744	num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
745	else
746	num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
747
748	return ret;
749	}
750
751	static num
752	num_rem (num a, num b)	737	num_rem (num a, num b)
753	{	738	{
754	num ret;	739	num ret;
755	long e1, e2, res;	740	long e1, e2, res;
756		741
…		…
792		777
793	num_set_ivalue (ret, res);	778	num_set_ivalue (ret, res);
794	return ret;	779	return ret;
795	}	780	}
796		781
		782	/* this completely disrespects NaNs */
797	static int	783	static int
798	num_eq (num a, num b)	784	num_cmp (num a, num b)
799	{	785	{
		786	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
800	int ret;	787	int ret;
801	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
802		788
803	if (is_fixnum)	789	if (is_fixnum)
804	ret = num_get_ivalue (a) == num_get_ivalue (b);	790	{
		791	IVALUE av = num_get_ivalue (a);
		792	IVALUE bv = num_get_ivalue (b);
		793
		794	ret = av == bv ? 0 : av < bv ? -1 : +1;
		795	}
805	else	796	else
806	ret = num_get_rvalue (a) == num_get_rvalue (b);	797	{
		798	RVALUE av = num_get_rvalue (a);
		799	RVALUE bv = num_get_rvalue (b);
		800
		801	ret = av == bv ? 0 : av < bv ? -1 : +1;
		802	}
807		803
808	return ret;	804	return ret;
809	}
810
811
812	static int
813	num_gt (num a, num b)
814	{
815	int ret;
816	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
817
818	if (is_fixnum)
819	ret = num_get_ivalue (a) > num_get_ivalue (b);
820	else
821	ret = num_get_rvalue (a) > num_get_rvalue (b);
822
823	return ret;
824	}
825
826	static int
827	num_ge (num a, num b)
828	{
829	return !num_lt (a, b);
830	}
831
832	static int
833	num_lt (num a, num b)
834	{
835	int ret;
836	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
837
838	if (is_fixnum)
839	ret = num_get_ivalue (a) < num_get_ivalue (b);
840	else
841	ret = num_get_rvalue (a) < num_get_rvalue (b);
842
843	return ret;
844	}
845
846	static int
847	num_le (num a, num b)
848	{
849	return !num_gt (a, b);
850	}	805	}
851		806
852	#if USE_MATH	807	#if USE_MATH
853		808
854	/* Round to nearest. Round to even if midway */	809	/* Round to nearest. Round to even if midway */
…		…
875	#endif	830	#endif
876		831
877	static int	832	static int
878	is_zero_rvalue (RVALUE x)	833	is_zero_rvalue (RVALUE x)
879	{	834	{
880	#if USE_FLOAT	835	#if USE_REAL
881	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	836	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
882	#else	837	#else
883	return x == 0;	838	return x == 0;
884	#endif	839	#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	}	840	}
901		841
902	/* allocate new cell segment */	842	/* allocate new cell segment */
903	static int	843	static int
904	alloc_cellseg (SCHEME_P_ int n)	844	alloc_cellseg (SCHEME_P_ int n)
…		…
978		918
979	/* get new cell. parameter a, b is marked by gc. */	919	/* get new cell. parameter a, b is marked by gc. */
980	static INLINE pointer	920	static INLINE pointer
981	get_cell_x (SCHEME_P_ pointer a, pointer b)	921	get_cell_x (SCHEME_P_ pointer a, pointer b)
982	{	922	{
983	if (SCHEME_V->free_cell == NIL)	923	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
984	{	924	{
985	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	925	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
986	return S_SINK;	926	return S_SINK;
987		927
988	if (SCHEME_V->free_cell == NIL)	928	if (SCHEME_V->free_cell == NIL)
…		…
1132		1072
1133	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);	1073	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134	set_typeflag (x, T_SYMBOL);	1074	set_typeflag (x, T_SYMBOL);
1135	setimmutable (car (x));	1075	setimmutable (car (x));
1136		1076
1137	location = hash_fn (name, vector_length (SCHEME_V->oblist));	1077	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)));	1078	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1139	return x;	1079	return x;
1140	}	1080	}
1141		1081
1142	static INLINE pointer	1082	static INLINE pointer
…		…
1144	{	1084	{
1145	int location;	1085	int location;
1146	pointer x;	1086	pointer x;
1147	char *s;	1087	char *s;
1148		1088
1149	location = hash_fn (name, vector_length (SCHEME_V->oblist));	1089	location = hash_fn (name, veclength (SCHEME_V->oblist));
1150		1090
1151	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1091	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1152	{	1092	{
1153	s = symname (car (x));	1093	s = symname (car (x));
1154		1094
…		…
1165	{	1105	{
1166	int i;	1106	int i;
1167	pointer x;	1107	pointer x;
1168	pointer ob_list = NIL;	1108	pointer ob_list = NIL;
1169		1109
1170	for (i = 0; i < vector_length (SCHEME_V->oblist); i++)	1110	for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1111	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1172	ob_list = cons (x, ob_list);	1112	ob_list = cons (x, ob_list);
1173		1113
1174	return ob_list;	1114	return ob_list;
1175	}	1115	}
…		…
1317	}	1257	}
1318		1258
1319	return q;	1259	return q;
1320	}	1260	}
1321		1261
1322	/* get new string */
1323	INTERFACE pointer	1262	INTERFACE pointer
1324	mk_string (SCHEME_P_ const char *str)	1263	mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1325	{	1264	{
1326	return mk_counted_string (SCHEME_A_ str, strlen (str));	1265	pointer x = get_cell (SCHEME_A_ NIL, NIL);
		1266
		1267	set_typeflag (x, T_STRING \| T_ATOM);
		1268	strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
		1269	strlength (x) = len;
		1270	return x;
1327	}	1271	}
1328		1272
1329	INTERFACE pointer	1273	INTERFACE pointer
1330	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)	1274	mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331	{	1275	{
…		…
1336	strlength (x) = len;	1280	strlength (x) = len;
1337	return x;	1281	return x;
1338	}	1282	}
1339		1283
1340	INTERFACE pointer	1284	INTERFACE pointer
1341	mk_empty_string (SCHEME_P_ uint32_t len, char fill)	1285	mk_string (SCHEME_P_ const char *str)
1342	{	1286	{
1343	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1287	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	}	1288	}
1350		1289
1351	INTERFACE pointer	1290	INTERFACE pointer
1352	mk_vector (SCHEME_P_ uint32_t len)	1291	mk_vector (SCHEME_P_ uint32_t len)
1353	{	1292	{
…		…
1358	fill_vector (pointer vec, pointer obj)	1297	fill_vector (pointer vec, pointer obj)
1359	{	1298	{
1360	int i;	1299	int i;
1361		1300
1362	for (i = 0; i < vec->object.vector.length; i++)	1301	for (i = 0; i < vec->object.vector.length; i++)
1363	vec->object.vector.vvalue[i] = obj;	1302	vecvalue (vec)[i] = obj;
1364	}	1303	}
1365		1304
1366	INTERFACE pointer	1305	INTERFACE pointer
1367	vector_elem (pointer vec, uint32_t ielem)	1306	vector_elem (pointer vec, uint32_t ielem)
1368	{	1307	{
1369	return vec->object.vector.vvalue[ielem];	1308	return vecvalue(vec)[ielem];
1370	}	1309	}
1371		1310
1372	INTERFACE void	1311	INTERFACE void
1373	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1312	set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374	{	1313	{
1375	vec->object.vector.vvalue[ielem] = a;	1314	vecvalue(vec)[ielem] = a;
1376	}	1315	}
1377		1316
1378	/* get new symbol */	1317	/* get new symbol */
1379	INTERFACE pointer	1318	INTERFACE pointer
1380	mk_symbol (SCHEME_P_ const char *name)	1319	mk_symbol (SCHEME_P_ const char *name)
…		…
1390		1329
1391	INTERFACE pointer	1330	INTERFACE pointer
1392	gensym (SCHEME_P)	1331	gensym (SCHEME_P)
1393	{	1332	{
1394	pointer x;	1333	pointer x;
1395	char name[40];
1396		1334
1397	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)	1335	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398	{	1336	{
1399	strcpy (name, "gensym-");	1337	char name[40] = "gensym-";
1400	xnum (name + 7, SCHEME_V->gensym_cnt);	1338	xnum (name + 7, SCHEME_V->gensym_cnt);
1401		1339
1402	/* first check oblist */	1340	/* first check oblist */
1403	x = oblist_find_by_name (SCHEME_A_ name);	1341	x = oblist_find_by_name (SCHEME_A_ name);
1404		1342
1405	if (x != NIL)	1343	if (x == NIL)
1406	continue;
1407	else
1408	{	1344	{
1409	x = oblist_add_by_name (SCHEME_A_ name);	1345	x = oblist_add_by_name (SCHEME_A_ name);
1410	return x;	1346	return x;
1411	}	1347	}
1412	}	1348	}
…		…
1421	char c, *p;	1357	char c, *p;
1422	int has_dec_point = 0;	1358	int has_dec_point = 0;
1423	int has_fp_exp = 0;	1359	int has_fp_exp = 0;
1424		1360
1425	#if USE_COLON_HOOK	1361	#if USE_COLON_HOOK
1426
1427	if ((p = strstr (q, "::")) != 0)	1362	if ((p = strstr (q, "::")) != 0)
1428	{	1363	{
1429	*p = 0;	1364	*p = 0;
1430	return cons (SCHEME_V->COLON_HOOK,	1365	return cons (SCHEME_V->COLON_HOOK,
1431	cons (cons (SCHEME_V->QUOTE,	1366	cons (cons (SCHEME_V->QUOTE,
1432	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));	1367	cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1433	}	1368	}
1434
1435	#endif	1369	#endif
1436		1370
1437	p = q;	1371	p = q;
1438	c = *p++;	1372	c = *p++;
1439		1373
…		…
1488		1422
1489	return mk_symbol (SCHEME_A_ strlwr (q));	1423	return mk_symbol (SCHEME_A_ strlwr (q));
1490	}	1424	}
1491	}	1425	}
1492		1426
1493	#if USE_FLOAT	1427	#if USE_REAL
1494	if (has_dec_point)	1428	if (has_dec_point)
1495	return mk_real (SCHEME_A_ atof (q));	1429	return mk_real (SCHEME_A_ atof (q));
1496	#endif	1430	#endif
1497		1431
1498	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1432	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
…		…
1500		1434
1501	/* make constant */	1435	/* make constant */
1502	static pointer	1436	static pointer
1503	mk_sharp_const (SCHEME_P_ char *name)	1437	mk_sharp_const (SCHEME_P_ char *name)
1504	{	1438	{
1505	long x;
1506	char tmp[STRBUFFSIZE];
1507
1508	if (!strcmp (name, "t"))	1439	if (!strcmp (name, "t"))
1509	return S_T;	1440	return S_T;
1510	else if (!strcmp (name, "f"))	1441	else if (!strcmp (name, "f"))
1511	return S_F;	1442	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) */	1443	else if (name == '\\') / #\w (character) */
1533	{	1444	{
1534	int c = 0;	1445	int c;
1535		1446
1536	if (stricmp (name + 1, "space") == 0)	1447	if (stricmp (name + 1, "space") == 0)
1537	c = ' ';	1448	c = ' ';
1538	else if (stricmp (name + 1, "newline") == 0)	1449	else if (stricmp (name + 1, "newline") == 0)
1539	c = '\n';	1450	c = '\n';
…		…
1541	c = '\r';	1452	c = '\r';
1542	else if (stricmp (name + 1, "tab") == 0)	1453	else if (stricmp (name + 1, "tab") == 0)
1543	c = '\t';	1454	c = '\t';
1544	else if (name[1] == 'x' && name[2] != 0)	1455	else if (name[1] == 'x' && name[2] != 0)
1545	{	1456	{
1546	int c1 = strtol (name + 2, 0, 16);	1457	long c1 = strtol (name + 2, 0, 16);
1547		1458
1548	if (c1 <= UCHAR_MAX)	1459	if (0 <= c1 && c1 <= UCHAR_MAX)
1549	c = c1;	1460	c = c1;
1550	else	1461	else
1551	return NIL;	1462	return NIL;
1552		1463	}
1553	#if USE_ASCII_NAMES	1464	#if USE_ASCII_NAMES
1554	}
1555	else if (is_ascii_name (name + 1, &c))	1465	else if (is_ascii_name (name + 1, &c))
1556	{
1557	/* nothing */	1466	/* nothing */;
1558	#endif	1467	#endif
1559	}
1560	else if (name[2] == 0)	1468	else if (name[2] == 0)
1561	c = name[1];	1469	c = name[1];
1562	else	1470	else
1563	return NIL;	1471	return NIL;
1564		1472
1565	return mk_character (SCHEME_A_ c);	1473	return mk_character (SCHEME_A_ c);
1566	}	1474	}
1567	else	1475	else
		1476	{
		1477	/* identify base by string index */
		1478	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
		1479	char base = strchr (baseidx, name);
		1480
		1481	if (base)
		1482	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
		1483
1568	return NIL;	1484	return NIL;
		1485	}
1569	}	1486	}
1570		1487
1571	/* ========== garbage collector ========== */	1488	/* ========== garbage collector ========== */
1572		1489
1573	/*--	1490	/*--
1574	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,	1491	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1575	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1492	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1576	* for marking.	1493	* for marking.
		1494	*
		1495	* The exception is vectors - vectors are currently marked recursively,
		1496	* which is inherited form tinyscheme and could be fixed by having another
		1497	* word of context in the vector
1577	*/	1498	*/
1578	static void	1499	static void
1579	mark (pointer a)	1500	mark (pointer a)
1580	{	1501	{
1581	pointer t, q, p;	1502	pointer t, q, p;
…		…
1583	t = 0;	1504	t = 0;
1584	p = a;	1505	p = a;
1585	E2:	1506	E2:
1586	setmark (p);	1507	setmark (p);
1587		1508
1588	if (is_vector (p))	1509	if (ecb_expect_false (is_vector (p)))
1589	{	1510	{
1590	int i;	1511	int i;
1591		1512
1592	for (i = 0; i < p->object.vector.length; i++)	1513	for (i = 0; i < p->object.vector.length; i++)
1593	mark (p->object.vector.vvalue[i]);	1514	mark (vecvalue (p)[i]);
1594	}	1515	}
1595		1516
1596	if (is_atom (p))	1517	if (is_atom (p))
1597	goto E6;	1518	goto E6;
1598		1519
…		…
1716	}	1637	}
1717		1638
1718	static void	1639	static void
1719	finalize_cell (SCHEME_P_ pointer a)	1640	finalize_cell (SCHEME_P_ pointer a)
1720	{	1641	{
		1642	/* TODO, fast bitmap check? */
1721	if (is_string (a))	1643	if (is_string (a))
1722	free (strvalue (a));	1644	free (strvalue (a));
1723	else if (is_vector (a))	1645	else if (is_vector (a))
1724	free (a->object.vector.vvalue);	1646	free (vecvalue (a));
1725	#if USE_PORTS	1647	#if USE_PORTS
1726	else if (is_port (a))	1648	else if (is_port (a))
1727	{	1649	{
1728	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)	1650	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729	port_close (SCHEME_A_ a, port_input \| port_output);	1651	port_close (SCHEME_A_ a, port_input \| port_output);
…		…
2556		2478
2557	if (f <= 1 \|\| f == 10) /* f is the base for numbers if > 1 */	2479	if (f <= 1 \|\| f == 10) /* f is the base for numbers if > 1 */
2558	{	2480	{
2559	if (num_is_integer (l))	2481	if (num_is_integer (l))
2560	xnum (p, ivalue_unchecked (l));	2482	xnum (p, ivalue_unchecked (l));
2561	#if USE_FLOAT	2483	#if USE_REAL
2562	else	2484	else
2563	{	2485	{
2564	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2486	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565	/* r5rs says there must be a '.' (unless 'e'?) */	2487	/* r5rs says there must be a '.' (unless 'e'?) */
2566	f = strcspn (p, ".e");	2488	f = strcspn (p, ".e");
…		…
2820	}	2742	}
2821	else if (is_number (a))	2743	else if (is_number (a))
2822	{	2744	{
2823	if (is_number (b))	2745	if (is_number (b))
2824	if (num_is_integer (a) == num_is_integer (b))	2746	if (num_is_integer (a) == num_is_integer (b))
2825	return num_eq (nvalue (a), nvalue (b));	2747	return num_cmp (nvalue (a), nvalue (b)) == 0;
2826		2748
2827	return 0;	2749	return 0;
2828	}	2750	}
2829	else if (is_character (a))	2751	else if (is_character (a))
2830	{	2752	{
…		…
2904	{	2826	{
2905	pointer slot = immutable_cons (variable, value);	2827	pointer slot = immutable_cons (variable, value);
2906		2828
2907	if (is_vector (car (env)))	2829	if (is_vector (car (env)))
2908	{	2830	{
2909	int location = hash_fn (symname (variable), vector_length (car (env)));	2831	int location = hash_fn (symname (variable), veclength (car (env)));
2910		2832
2911	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2833	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2912	}	2834	}
2913	else	2835	else
2914	set_car (env, immutable_cons (slot, car (env)));	2836	set_car (env, immutable_cons (slot, car (env)));
…		…
2922		2844
2923	for (x = env; x != NIL; x = cdr (x))	2845	for (x = env; x != NIL; x = cdr (x))
2924	{	2846	{
2925	if (is_vector (car (x)))	2847	if (is_vector (car (x)))
2926	{	2848	{
2927	location = hash_fn (symname (hdl), vector_length (car (x)));	2849	location = hash_fn (symname (hdl), veclength (car (x)));
2928	y = vector_elem (car (x), location);	2850	y = vector_elem (car (x), location);
2929	}	2851	}
2930	else	2852	else
2931	y = car (x);	2853	y = car (x);
2932		2854
…		…
3042	#if USE_ERROR_HOOK	2964	#if USE_ERROR_HOOK
3043	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);	2965	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044		2966
3045	if (x != NIL)	2967	if (x != NIL)
3046	{	2968	{
3047	if (a)	2969	pointer code = a
3048	SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL);	2970	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049	else	2971	: NIL;
3050	SCHEME_V->code = NIL;
3051		2972
3052	SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code);	2973	code = cons (mk_string (SCHEME_A_ s), code);
3053	setimmutable (car (SCHEME_V->code));	2974	setimmutable (car (code));
3054	SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code);	2975	SCHEME_V->code = cons (slot_value_in_env (x), code);
3055	SCHEME_V->op = OP_EVAL;	2976	SCHEME_V->op = OP_EVAL;
3056		2977
3057	return S_T;	2978	return S_T;
3058	}	2979	}
3059	#endif	2980	#endif
…		…
3350	s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);	3271	s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351	s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);	3272	s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352	s_goto (OP_READ_INTERNAL);	3273	s_goto (OP_READ_INTERNAL);
3353		3274
3354	case OP_T1LVL: /* top level */	3275	case OP_T1LVL: /* top level */
3355	SCHEME_V->code = SCHEME_V->value;	3276	SCHEME_V->code = SCHEME_V->value;
3356	SCHEME_V->inport = SCHEME_V->save_inport;	3277	SCHEME_V->inport = SCHEME_V->save_inport;
3357	s_goto (OP_EVAL);	3278	s_goto (OP_EVAL);
3358		3279
3359	case OP_READ_INTERNAL: /* internal read */	3280	case OP_READ_INTERNAL: /* internal read */
3360	SCHEME_V->tok = token (SCHEME_A);	3281	SCHEME_V->tok = token (SCHEME_A);
…		…
3410	else	3331	else
3411	Error_1 ("eval: unbound variable:", SCHEME_V->code);	3332	Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412	}	3333	}
3413	else if (is_pair (SCHEME_V->code))	3334	else if (is_pair (SCHEME_V->code))
3414	{	3335	{
		3336	x = car (SCHEME_V->code);
		3337
3415	if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */	3338	if (is_syntax (x)) /* SYNTAX */
3416	{	3339	{
3417	SCHEME_V->code = cdr (SCHEME_V->code);	3340	SCHEME_V->code = cdr (SCHEME_V->code);
3418	s_goto (syntaxnum (x));	3341	s_goto (syntaxnum (x));
3419	}	3342	}
3420	else /* first, eval top element and eval arguments */	3343	else /* first, eval top element and eval arguments */
3421	{	3344	{
3422	s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);	3345	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)); */	3346	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424	SCHEME_V->code = car (SCHEME_V->code);	3347	SCHEME_V->code = x;
3425	s_goto (OP_EVAL);	3348	s_goto (OP_EVAL);
3426	}	3349	}
3427	}	3350	}
3428	else	3351	else
3429	s_return (SCHEME_V->code);	3352	s_return (SCHEME_V->code);
…		…
3987	SCHEME_V->code = car (SCHEME_V->args);	3910	SCHEME_V->code = car (SCHEME_V->args);
3988	s_goto (OP_EVAL);	3911	s_goto (OP_EVAL);
3989		3912
3990	case OP_CONTINUATION: /* call-with-current-continuation */	3913	case OP_CONTINUATION: /* call-with-current-continuation */
3991	SCHEME_V->code = car (SCHEME_V->args);	3914	SCHEME_V->code = car (SCHEME_V->args);
3992	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL);	3915	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993	s_goto (OP_APPLY);	3916	s_goto (OP_APPLY);
3994	}	3917	}
3995		3918
3996	return S_T;	3919	abort ();
3997	}	3920	}
3998		3921
3999	static pointer	3922	static pointer
4000	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	3923	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4001	{	3924	{
…		…
4130		4053
4131	case OP_ADD: /* + */	4054	case OP_ADD: /* + */
4132	v = num_zero;	4055	v = num_zero;
4133		4056
4134	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4057	for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4135	v = num_add (v, nvalue (car (x)));	4058	v = num_op ('+', v, nvalue (car (x)));
4136		4059
4137	s_return (mk_number (SCHEME_A_ v));	4060	s_return (mk_number (SCHEME_A_ v));
4138		4061
4139	case OP_MUL: /* * */	4062	case OP_MUL: /* * */
4140	v = num_one;	4063	v = num_one;
4141		4064
4142	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4065	for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4143	v = num_mul (v, nvalue (car (x)));	4066	v = num_op ('+', v, nvalue (car (x)));
4144		4067
4145	s_return (mk_number (SCHEME_A_ v));	4068	s_return (mk_number (SCHEME_A_ v));
4146		4069
4147	case OP_SUB: /* - */	4070	case OP_SUB: /* - */
4148	if (cdr (SCHEME_V->args) == NIL)	4071	if (cdr (SCHEME_V->args) == NIL)
…		…
4155	x = cdr (SCHEME_V->args);	4078	x = cdr (SCHEME_V->args);
4156	v = nvalue (car (SCHEME_V->args));	4079	v = nvalue (car (SCHEME_V->args));
4157	}	4080	}
4158		4081
4159	for (; x != NIL; x = cdr (x))	4082	for (; x != NIL; x = cdr (x))
4160	v = num_sub (v, nvalue (car (x)));	4083	v = num_op ('+', v, nvalue (car (x)));
4161		4084
4162	s_return (mk_number (SCHEME_A_ v));	4085	s_return (mk_number (SCHEME_A_ v));
4163		4086
4164	case OP_DIV: /* / */	4087	case OP_DIV: /* / */
4165	if (cdr (SCHEME_V->args) == NIL)	4088	if (cdr (SCHEME_V->args) == NIL)
…		…
4196	}	4119	}
4197		4120
4198	for (; x != NIL; x = cdr (x))	4121	for (; x != NIL; x = cdr (x))
4199	{	4122	{
4200	if (ivalue (car (x)) != 0)	4123	if (ivalue (car (x)) != 0)
4201	v = num_intdiv (v, nvalue (car (x)));	4124	v = num_op ('/', v, nvalue (car (x)));
4202	else	4125	else
4203	Error_0 ("quotient: division by zero");	4126	Error_0 ("quotient: division by zero");
4204	}	4127	}
4205		4128
4206	s_return (mk_number (SCHEME_A_ v));	4129	s_return (mk_number (SCHEME_A_ v));
…		…
4505		4428
4506	s_return (vec);	4429	s_return (vec);
4507	}	4430	}
4508		4431
4509	case OP_VECLEN: /* vector-length */	4432	case OP_VECLEN: /* vector-length */
4510	s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args))));	4433	s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511		4434
4512	case OP_VECREF: /* vector-ref */	4435	case OP_VECREF: /* vector-ref */
4513	{	4436	{
4514	int index;	4437	int index;
4515		4438
4516	index = ivalue (cadr (SCHEME_V->args));	4439	index = ivalue (cadr (SCHEME_V->args));
4517		4440
4518	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4441	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));	4442	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520		4443
4521	s_return (vector_elem (car (SCHEME_V->args), index));	4444	s_return (vector_elem (car (SCHEME_V->args), index));
4522	}	4445	}
4523		4446
…		…
4528	if (is_immutable (car (SCHEME_V->args)))	4451	if (is_immutable (car (SCHEME_V->args)))
4529	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));	4452	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4530		4453
4531	index = ivalue (cadr (SCHEME_V->args));	4454	index = ivalue (cadr (SCHEME_V->args));
4532		4455
4533	if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4456	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));	4457	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535		4458
4536	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));	4459	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4537	s_return (car (SCHEME_V->args));	4460	s_return (car (SCHEME_V->args));
4538	}	4461	}
…		…
4594	}	4517	}
4595	}	4518	}
4596	}	4519	}
4597		4520
4598	static pointer	4521	static pointer
		4522	opexe_r (SCHEME_P_ enum scheme_opcodes op)
		4523	{
		4524	pointer x = SCHEME_V->args;
		4525
		4526	for (;;)
		4527	{
		4528	num v = nvalue (car (x));
		4529	x = cdr (x);
		4530
		4531	if (x == NIL)
		4532	break;
		4533
		4534	int r = num_cmp (v, nvalue (car (x)));
		4535
		4536	switch (op)
		4537	{
		4538	case OP_NUMEQ: r = r == 0; break;
		4539	case OP_LESS: r = r < 0; break;
		4540	case OP_GRE: r = r > 0; break;
		4541	case OP_LEQ: r = r <= 0; break;
		4542	case OP_GEQ: r = r >= 0; break;
		4543	}
		4544
		4545	if (!r)
		4546	s_return (S_F);
		4547	}
		4548
		4549	s_return (S_T);
		4550	}
		4551
		4552	static pointer
4599	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4553	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4600	{	4554	{
4601	pointer x;	4555	pointer x = SCHEME_V->args;
4602	num v;	4556	pointer a = car (x);
4603	int (*comp_func) (num, num);	4557	pointer d = cdr (x);
		4558	int r;
4604		4559
4605	switch (op)	4560	switch (op)
4606	{	4561	{
4607	case OP_NOT: /* not */	4562	case OP_NOT: /* not */ r = is_false (a) ; break;
4608	s_retbool (is_false (car (SCHEME_V->args)));	4563	case OP_BOOLP: /* boolean? */ r = a == S_F \|\| a == S_T; break;
		4564	case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
		4565	case OP_NULLP: /* null? */ r = a == NIL ; break;
		4566	case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
		4567	case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
		4568	case OP_STRINGP: /* string? */ r = is_string (a) ; break;
		4569	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
		4570	case OP_REALP: /* real? / r = is_number (a) ; break; / all numbers are real */
		4571	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4609		4572
4610	case OP_BOOLP: /* boolean? */
4611	s_retbool (car (SCHEME_V->args) == S_F \|\| car (SCHEME_V->args) == S_T);
4612
4613	case OP_EOFOBJP: /* boolean? */
4614	s_retbool (car (SCHEME_V->args) == S_EOF);
4615
4616	case OP_NULLP: /* null? */
4617	s_retbool (car (SCHEME_V->args) == NIL);
4618
4619	case OP_NUMEQ: /* = */
4620	case OP_LESS: /* < */
4621	case OP_GRE: /* > */
4622	case OP_LEQ: /* <= */
4623	case OP_GEQ: /* >= */
4624	switch (op)
4625	{
4626	case OP_NUMEQ:
4627	comp_func = num_eq;
4628	break;
4629
4630	case OP_LESS:
4631	comp_func = num_lt;
4632	break;
4633
4634	case OP_GRE:
4635	comp_func = num_gt;
4636	break;
4637
4638	case OP_LEQ:
4639	comp_func = num_le;
4640	break;
4641
4642	case OP_GEQ:
4643	comp_func = num_ge;
4644	break;
4645	}
4646
4647	x = SCHEME_V->args;
4648	v = nvalue (car (x));
4649	x = cdr (x);
4650
4651	for (; x != NIL; x = cdr (x))
4652	{
4653	if (!comp_func (v, nvalue (car (x))))
4654	s_retbool (0);
4655
4656	v = nvalue (car (x));
4657	}
4658
4659	s_retbool (1);
4660
4661	case OP_SYMBOLP: /* symbol? */
4662	s_retbool (is_symbol (car (SCHEME_V->args)));
4663
4664	case OP_NUMBERP: /* number? */
4665	s_retbool (is_number (car (SCHEME_V->args)));
4666
4667	case OP_STRINGP: /* string? */
4668	s_retbool (is_string (car (SCHEME_V->args)));
4669
4670	case OP_INTEGERP: /* integer? */
4671	s_retbool (is_integer (car (SCHEME_V->args)));
4672
4673	case OP_REALP: /* real? */
4674	s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */
4675
4676	case OP_CHARP: /* char? */
4677	s_retbool (is_character (car (SCHEME_V->args)));
4678	#if USE_CHAR_CLASSIFIERS	4573	#if USE_CHAR_CLASSIFIERS
4679
4680	case OP_CHARAP: /* char-alphabetic? */	4574	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;
4681	s_retbool (Cisalpha (ivalue (car (SCHEME_V->args))));	4575	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;
4682
4683	case OP_CHARNP: /* char-numeric? */
4684	s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));
4685
4686	case OP_CHARWP: /* char-whitespace? */	4576	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;
4687	s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));
4688
4689	case OP_CHARUP: /* char-upper-case? */	4577	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;
4690	s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));
4691
4692	case OP_CHARLP: /* char-lower-case? */	4578	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;
4693	s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
4694	#endif	4579	#endif
		4580
4695	#if USE_PORTS	4581	#if USE_PORTS
4696		4582	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4697	case OP_PORTP: /* port? */
4698	s_retbool (is_port (car (SCHEME_V->args)));
4699
4700	case OP_INPORTP: /* input-port? */	4583	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4701	s_retbool (is_inport (car (SCHEME_V->args)));
4702
4703	case OP_OUTPORTP: /* output-port? */	4584	case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4704	s_retbool (is_outport (car (SCHEME_V->args)));
4705	#endif	4585	#endif
4706		4586
4707	case OP_PROCP: /* procedure? */	4587	case OP_PROCP: /* procedure? */
4708		4588
4709	/*--	4589	/*--
4710	* continuation should be procedure by the example	4590	* continuation should be procedure by the example
4711	* (call-with-current-continuation procedure?) ==> #t	4591	* (call-with-current-continuation procedure?) ==> #t
4712	* in R^3 report sec. 6.9	4592	* in R^3 report sec. 6.9
4713	*/	4593	*/
4714	s_retbool (is_proc (car (SCHEME_V->args)) \|\| is_closure (car (SCHEME_V->args))	4594	r = is_proc (a) \|\| is_closure (a) \|\| is_continuation (a) \|\| is_foreign (a);
4715	\|\| is_continuation (car (SCHEME_V->args)) \|\| is_foreign (car (SCHEME_V->args)));	4595	break;
4716		4596
4717	case OP_PAIRP: /* pair? */	4597	case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4718	s_retbool (is_pair (car (SCHEME_V->args)));	4598	case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4719		4599	case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4720	case OP_LISTP: /* list? */	4600	case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4721	s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0);	4601	case OP_EQ: /* eq? */ r = a == cadr (x) ; break;
4722		4602	case OP_EQV: /* eqv? */ r = eqv (a, cadr (x)) ; break;
4723	case OP_ENVP: /* environment? */
4724	s_retbool (is_environment (car (SCHEME_V->args)));
4725
4726	case OP_VECTORP: /* vector? */
4727	s_retbool (is_vector (car (SCHEME_V->args)));
4728
4729	case OP_EQ: /* eq? */
4730	s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));
4731
4732	case OP_EQV: /* eqv? */
4733	s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
4734	}	4603	}
4735		4604
4736	return S_T;	4605	s_retbool (r);
4737	}	4606	}
4738		4607
4739	static pointer	4608	static pointer
4740	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4609	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4741	{	4610	{
…		…
5055	case OP_CURR_ENV: /* current-environment */	4924	case OP_CURR_ENV: /* current-environment */
5056	s_return (SCHEME_V->envir);	4925	s_return (SCHEME_V->envir);
5057		4926
5058	}	4927	}
5059		4928
5060	return S_T;	4929	abort ();
5061	}	4930	}
5062		4931
5063	static pointer	4932	static pointer
5064	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4933	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5065	{	4934	{
…		…
5381		5250
5382	case OP_PVECFROM:	5251	case OP_PVECFROM:
5383	{	5252	{
5384	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5253	int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385	pointer vec = car (SCHEME_V->args);	5254	pointer vec = car (SCHEME_V->args);
5386	int len = vector_length (vec);	5255	int len = veclength (vec);
5387		5256
5388	if (i == len)	5257	if (i == len)
5389	{	5258	{
5390	putstr (SCHEME_A_ ")");	5259	putstr (SCHEME_A_ ")");
5391	s_return (S_T);	5260	s_return (S_T);
…		…
5404	s_goto (OP_P0LIST);	5273	s_goto (OP_P0LIST);
5405	}	5274	}
5406	}	5275	}
5407	}	5276	}
5408		5277
5409	return S_T;	5278	abort ();
5410	}	5279	}
5411		5280
5412	static pointer	5281	static pointer
5413	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5282	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5414	{	5283	{
…		…
5465		5334
5466	case OP_MACROP: /* macro? */	5335	case OP_MACROP: /* macro? */
5467	s_retbool (is_macro (car (SCHEME_V->args)));	5336	s_retbool (is_macro (car (SCHEME_V->args)));
5468	}	5337	}
5469		5338
5470	return S_T; /* NOTREACHED */	5339	abort ();
5471	}	5340	}
5472		5341
5473	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);	5342	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5474		5343
5475	typedef int (*test_predicate) (pointer);	5344	typedef int (*test_predicate) (pointer);
…		…
5570	int ok = 1;	5439	int ok = 1;
5571	char msg[STRBUFFSIZE];	5440	char msg[STRBUFFSIZE];
5572	int n = list_length (SCHEME_A_ SCHEME_V->args);	5441	int n = list_length (SCHEME_A_ SCHEME_V->args);
5573		5442
5574	/* Check number of arguments */	5443	/* Check number of arguments */
5575	if (n < pcd->min_arity)	5444	if (ecb_expect_false (n < pcd->min_arity))
5576	{	5445	{
5577	ok = 0;	5446	ok = 0;
5578	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5447	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5579	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5448	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5580	}	5449	}
5581		5450	else if (ecb_excpect_false (n > pcd->max_arity))
5582	if (ok && n > pcd->max_arity)
5583	{	5451	{
5584	ok = 0;	5452	ok = 0;
5585	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5453	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5586	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5454	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5587	}	5455	}
5588		5456
5589	if (ok)	5457	if (ecb_expect_false (ok))
5590	{	5458	{
5591	if (pcd->arg_tests_encoding)	5459	if (pcd->arg_tests_encoding)
5592	{	5460	{
5593	int i = 0;	5461	int i = 0;
5594	int j;	5462	int j;
…		…
5638	}	5506	}
5639	#endif	5507	#endif
5640		5508
5641	ok_to_freely_gc (SCHEME_A);	5509	ok_to_freely_gc (SCHEME_A);
5642		5510
5643	if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)	5511	if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5644	return;	5512	return;
5645		5513
5646	#if USE_ERROR_CHECKING	5514	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647	if (SCHEME_V->no_memory)
5648	{	5515	{
5649	xwrstr ("No memory!\n");	5516	xwrstr ("No memory!\n");
5650	return;	5517	return;
5651	}	5518	}
5652	#endif
5653	}	5519	}
5654	}	5520	}
5655		5521
5656	/* ========== Initialization of internal keywords ========== */	5522	/* ========== Initialization of internal keywords ========== */
5657		5523
…		…
5708		5574
5709	case 'd':	5575	case 'd':
5710	return OP_COND0; /* cond */	5576	return OP_COND0; /* cond */
5711		5577
5712	case '*':	5578	case '*':
5713	return OP_LET0AST; /* let* */	5579	return OP_LET0AST;/* let* */
5714		5580
5715	default:	5581	default:
5716	return OP_SET0; /* set! */	5582	return OP_SET0; /* set! */
5717	}	5583	}
5718		5584
…		…
5740		5606
5741	case 'f':	5607	case 'f':
5742	return OP_DEF0; /* define */	5608	return OP_DEF0; /* define */
5743		5609
5744	default:	5610	default:
5745	return OP_LET0REC; /* letrec */	5611	return OP_LET0REC;/* letrec */
5746	}	5612	}
5747		5613
5748	default:	5614	default:
5749	return OP_C0STREAM; /* cons-stream */	5615	return OP_C0STREAM; /* cons-stream */
5750	}	5616	}
…		…
5817	set_cdr (S_T, S_T);	5683	set_cdr (S_T, S_T);
5818	/* init F */	5684	/* init F */
5819	set_typeflag (S_F, T_ATOM \| T_MARK);	5685	set_typeflag (S_F, T_ATOM \| T_MARK);
5820	set_car (S_F, S_F);	5686	set_car (S_F, S_F);
5821	set_cdr (S_F, S_F);	5687	set_cdr (S_F, S_F);
		5688	/* init EOF_OBJ */
		5689	set_typeflag (S_EOF, T_ATOM \| T_MARK);
		5690	set_car (S_EOF, S_EOF);
		5691	set_cdr (S_EOF, S_EOF);
5822	/* init sink */	5692	/* init sink */
5823	set_typeflag (S_SINK, T_PAIR \| T_MARK);	5693	set_typeflag (S_SINK, T_PAIR \| T_MARK);
5824	set_car (S_SINK, NIL);	5694	set_car (S_SINK, NIL);
		5695
5825	/* init c_nest */	5696	/* init c_nest */
5826	SCHEME_V->c_nest = NIL;	5697	SCHEME_V->c_nest = NIL;
5827		5698
5828	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	5699	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5829	/* init global_env */	5700	/* init global_env */
…		…
5847	for (i = 0; i < n; i++)	5718	for (i = 0; i < n; i++)
5848	if (dispatch_table[i].name != 0)	5719	if (dispatch_table[i].name != 0)
5849	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5720	assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5850		5721
5851	/* initialization of global pointers to special symbols */	5722	/* initialization of global pointers to special symbols */
5852	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5723	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5853	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5724	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5854	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5725	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5855	SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");	5726	SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5856	SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");	5727	SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5857	SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");	5728	SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5858	SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "colon-hook");	5729	SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "colon-hook");
5859	SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "error-hook");	5730	SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "error-hook");
5860	SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "sharp-hook");	5731	SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "sharp-hook");
5861	SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "compile-hook");	5732	SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "compile-hook");
5862		5733
5863	return !SCHEME_V->no_memory;	5734	return !SCHEME_V->no_memory;
5864	}	5735	}
5865		5736
…		…
6112		5983
6113	/* ========== Main ========== */	5984	/* ========== Main ========== */
6114		5985
6115	#if STANDALONE	5986	#if STANDALONE
6116		5987
6117	# if defined(__APPLE__) && !defined (OSX)
6118	int
6119	main ()
6120	{
6121	extern MacTS_main (int argc, char **argv);
6122	char **argv;
6123	int argc = ccommand (&argv);
6124
6125	MacTS_main (argc, argv);
6126	return 0;
6127	}
6128
6129	int
6130	MacTS_main (int argc, char **argv)
6131	{
6132	# else
6133	int	5988	int
6134	main (int argc, char **argv)	5989	main (int argc, char **argv)
6135	{	5990	{
6136	# endif
6137	# if USE_MULTIPLICITY	5991	# if USE_MULTIPLICITY
6138	scheme ssc;	5992	scheme ssc;
6139	scheme *const SCHEME_V = &ssc;	5993	scheme *const SCHEME_V = &ssc;
6140	# else	5994	# else
6141	# endif	5995	# endif

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.4 by root, Wed Nov 25 10:49:29 2015 UTC vs. Revision 1.15 by root, Thu Nov 26 09:05:20 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.4 by root, Wed Nov 25 10:49:29 2015 UTC vs.
Revision 1.15 by root, Thu Nov 26 09:05:20 2015 UTC