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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.18 by root, Thu Nov 26 21:32:16 2015 UTC vs.
Revision 1.24 by root, Fri Nov 27 02:12:08 2015 UTC

…		…
28	#endif	28	#endif
29	#if USE_MATH	29	#if USE_MATH
30	# include <math.h>	30	# include <math.h>
31	#endif	31	#endif
32		32
		33	#include "ecb.h"
		34
33	#include <sys/types.h>	35	#include <sys/types.h>
34	#include <sys/stat.h>	36	#include <sys/stat.h>
35	#include <fcntl.h>	37	#include <fcntl.h>
36		38
37	#include <string.h>	39	#include <string.h>
…		…
65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	67	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	68	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67	#define S_SINK (&SCHEME_V->xsink)	69	#define S_SINK (&SCHEME_V->xsink)
68	#define S_EOF (&SCHEME_V->xEOF_OBJ)	70	#define S_EOF (&SCHEME_V->xEOF_OBJ)
69		71
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	#else
76	# define ecb_expect_false(expr) !!(expr)
77	# define ecb_expect_true(expr) !!(expr)
78	#endif
79
80	#if !USE_MULTIPLICITY	72	#if !USE_MULTIPLICITY
81	static scheme sc;	73	static scheme sc;
82	#endif	74	#endif
83		75
84	static void	76	static void
…		…
153		145
154	#define toupper(c) xtoupper (c)	146	#define toupper(c) xtoupper (c)
155	#define tolower(c) xtolower (c)	147	#define tolower(c) xtolower (c)
156	#define isdigit(c) xisdigit (c)	148	#define isdigit(c) xisdigit (c)
157		149
158	#if USE_STRLWR	150	#if USE_IGNORECASE
159	static const char *	151	static const char *
160	strlwr (char *s)	152	xstrlwr (char *s)
161	{	153	{
162	const char *p = s;	154	const char *p = s;
163		155
164	while (*s)	156	while (*s)
165	{	157	{
…		…
167	s++;	159	s++;
168	}	160	}
169		161
170	return p;	162	return p;
171	}	163	}
172	#endif
173		164
		165	#define stricmp(a,b) strcasecmp (a, b)
		166	#define strlwr(s) xstrlwr (s)
		167
		168	#else
174	#define stricmp(a,b) strcmp (a, b)	169	# define stricmp(a,b) strcmp (a, b)
175	#define strlwr(s) (s)	170	# define strlwr(s) (s)
		171	#endif
176		172
177	#ifndef prompt	173	#ifndef prompt
178	# define prompt "ts> "	174	# define prompt "ts> "
179	#endif	175	#endif
180		176
…		…
223	#if USE_MATH	219	#if USE_MATH
224	static double round_per_R5RS (double x);	220	static double round_per_R5RS (double x);
225	#endif	221	#endif
226	static int is_zero_rvalue (RVALUE x);	222	static int is_zero_rvalue (RVALUE x);
227		223
228	static INLINE int	224	ecb_inline int
229	num_is_integer (pointer p)	225	num_is_integer (pointer p)
230	{	226	{
231	return num_is_fixnum (p->object.number);	227	return num_is_fixnum (p->object.number);
232	}	228	}
233		229
…		…
237	/* macros for cell operations */	233	/* macros for cell operations */
238	#define typeflag(p) ((p)->flag + 0)	234	#define typeflag(p) ((p)->flag + 0)
239	#define set_typeflag(p,v) ((p)->flag = (v))	235	#define set_typeflag(p,v) ((p)->flag = (v))
240	#define type(p) (typeflag (p) & T_MASKTYPE)	236	#define type(p) (typeflag (p) & T_MASKTYPE)
241		237
242	INTERFACE INLINE int	238	INTERFACE int
243	is_string (pointer p)	239	is_string (pointer p)
244	{	240	{
245	return type (p) == T_STRING;	241	return type (p) == T_STRING;
246	}	242	}
247		243
248	#define strvalue(p) ((p)->object.string.svalue)	244	#define strvalue(p) ((p)->object.string.svalue)
249	#define strlength(p) ((p)->object.string.length)	245	#define strlength(p) ((p)->object.string.length)
250		246
251	INTERFACE int is_list (SCHEME_P_ pointer p);	247	INTERFACE int is_list (SCHEME_P_ pointer p);
		248
252	INTERFACE INLINE int	249	INTERFACE int
253	is_vector (pointer p)	250	is_vector (pointer p)
254	{	251	{
255	return type (p) == T_VECTOR;	252	return type (p) == T_VECTOR;
256	}	253	}
257		254
…		…
266	vector_length (pointer vec)	263	vector_length (pointer vec)
267	{	264	{
268	return vec->object.vector.length;	265	return vec->object.vector.length;
269	}	266	}
270		267
271	INTERFACE INLINE int	268	INTERFACE int
272	is_number (pointer p)	269	is_number (pointer p)
273	{	270	{
274	return type (p) == T_NUMBER;	271	return type (p) == T_NUMBER;
275	}	272	}
276		273
277	INTERFACE INLINE int	274	INTERFACE int
278	is_integer (pointer p)	275	is_integer (pointer p)
279	{	276	{
280	if (!is_number (p))	277	if (!is_number (p))
281	return 0;	278	return 0;
282		279
…		…
284	return 1;	281	return 1;
285		282
286	return 0;	283	return 0;
287	}	284	}
288		285
289	INTERFACE INLINE int	286	INTERFACE int
290	is_real (pointer p)	287	is_real (pointer p)
291	{	288	{
292	return is_number (p) && !num_is_fixnum (p->object.number);	289	return is_number (p) && !num_is_fixnum (p->object.number);
293	}	290	}
294		291
295	INTERFACE INLINE int	292	INTERFACE int
296	is_character (pointer p)	293	is_character (pointer p)
297	{	294	{
298	return type (p) == T_CHARACTER;	295	return type (p) == T_CHARACTER;
299	}	296	}
300		297
301	INTERFACE INLINE char *	298	INTERFACE char *
302	string_value (pointer p)	299	string_value (pointer p)
303	{	300	{
304	return strvalue (p);	301	return strvalue (p);
305	}	302	}
306		303
307	INLINE num	304	ecb_inline num
308	nvalue (pointer p)	305	nvalue (pointer p)
309	{	306	{
310	return (p)->object.number;	307	return (p)->object.number;
311	}	308	}
312		309
…		…
342	#else	339	#else
343	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	340	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
344	# define set_num_integer(p) 0	341	# define set_num_integer(p) 0
345	# define set_num_real(p) 0	342	# define set_num_real(p) 0
346	#endif	343	#endif
		344
347	INTERFACE long	345	INTERFACE long
348	charvalue (pointer p)	346	charvalue (pointer p)
349	{	347	{
350	return ivalue_unchecked (p);	348	return ivalue_unchecked (p);
351	}	349	}
352		350
353	INTERFACE INLINE int	351	INTERFACE int
354	is_port (pointer p)	352	is_port (pointer p)
355	{	353	{
356	return type (p) == T_PORT;	354	return type (p) == T_PORT;
357	}	355	}
358		356
359	INTERFACE INLINE int	357	INTERFACE int
360	is_inport (pointer p)	358	is_inport (pointer p)
361	{	359	{
362	return is_port (p) && p->object.port->kind & port_input;	360	return is_port (p) && p->object.port->kind & port_input;
363	}	361	}
364		362
365	INTERFACE INLINE int	363	INTERFACE int
366	is_outport (pointer p)	364	is_outport (pointer p)
367	{	365	{
368	return is_port (p) && p->object.port->kind & port_output;	366	return is_port (p) && p->object.port->kind & port_output;
369	}	367	}
370		368
371	INTERFACE INLINE int	369	INTERFACE int
372	is_pair (pointer p)	370	is_pair (pointer p)
373	{	371	{
374	return type (p) == T_PAIR;	372	return type (p) == T_PAIR;
375	}	373	}
376		374
…		…
408	pair_cdr (pointer p)	406	pair_cdr (pointer p)
409	{	407	{
410	return cdr (p);	408	return cdr (p);
411	}	409	}
412		410
413	INTERFACE INLINE int	411	INTERFACE int
414	is_symbol (pointer p)	412	is_symbol (pointer p)
415	{	413	{
416	return type (p) == T_SYMBOL;	414	return type (p) == T_SYMBOL;
417	}	415	}
418		416
419	INTERFACE INLINE char *	417	INTERFACE char *
420	symname (pointer p)	418	symname (pointer p)
421	{	419	{
422	return strvalue (car (p));	420	return strvalue (car (p));
423	}	421	}
424		422
425	#if USE_PLIST	423	#if USE_PLIST
426	SCHEME_EXPORT INLINE int	424	SCHEME_EXPORT int
427	hasprop (pointer p)	425	hasprop (pointer p)
428	{	426	{
429	return typeflag (p) & T_SYMBOL;	427	return typeflag (p) & T_SYMBOL;
430	}	428	}
431		429
432	# define symprop(p) cdr(p)	430	# define symprop(p) cdr(p)
433	#endif	431	#endif
434		432
435	INTERFACE INLINE int	433	INTERFACE int
436	is_syntax (pointer p)	434	is_syntax (pointer p)
437	{	435	{
438	return typeflag (p) & T_SYNTAX;	436	return typeflag (p) & T_SYNTAX;
439	}	437	}
440		438
441	INTERFACE INLINE int	439	INTERFACE int
442	is_proc (pointer p)	440	is_proc (pointer p)
443	{	441	{
444	return type (p) == T_PROC;	442	return type (p) == T_PROC;
445	}	443	}
446		444
447	INTERFACE INLINE int	445	INTERFACE int
448	is_foreign (pointer p)	446	is_foreign (pointer p)
449	{	447	{
450	return type (p) == T_FOREIGN;	448	return type (p) == T_FOREIGN;
451	}	449	}
452		450
453	INTERFACE INLINE char *	451	INTERFACE char *
454	syntaxname (pointer p)	452	syntaxname (pointer p)
455	{	453	{
456	return strvalue (car (p));	454	return strvalue (car (p));
457	}	455	}
458		456
459	#define procnum(p) ivalue (p)	457	#define procnum(p) ivalue (p)
460	static const char *procname (pointer x);	458	static const char *procname (pointer x);
461		459
462	INTERFACE INLINE int	460	INTERFACE int
463	is_closure (pointer p)	461	is_closure (pointer p)
464	{	462	{
465	return type (p) == T_CLOSURE;	463	return type (p) == T_CLOSURE;
466	}	464	}
467		465
468	INTERFACE INLINE int	466	INTERFACE int
469	is_macro (pointer p)	467	is_macro (pointer p)
470	{	468	{
471	return type (p) == T_MACRO;	469	return type (p) == T_MACRO;
472	}	470	}
473		471
474	INTERFACE INLINE pointer	472	INTERFACE pointer
475	closure_code (pointer p)	473	closure_code (pointer p)
476	{	474	{
477	return car (p);	475	return car (p);
478	}	476	}
479		477
480	INTERFACE INLINE pointer	478	INTERFACE pointer
481	closure_env (pointer p)	479	closure_env (pointer p)
482	{	480	{
483	return cdr (p);	481	return cdr (p);
484	}	482	}
485		483
486	INTERFACE INLINE int	484	INTERFACE int
487	is_continuation (pointer p)	485	is_continuation (pointer p)
488	{	486	{
489	return type (p) == T_CONTINUATION;	487	return type (p) == T_CONTINUATION;
490	}	488	}
491		489
492	#define cont_dump(p) cdr (p)	490	#define cont_dump(p) cdr (p)
493	#define set_cont_dump(p,v) set_cdr ((p), (v))	491	#define set_cont_dump(p,v) set_cdr ((p), (v))
494		492
495	/* To do: promise should be forced ONCE only */	493	/* To do: promise should be forced ONCE only */
496	INTERFACE INLINE int	494	INTERFACE int
497	is_promise (pointer p)	495	is_promise (pointer p)
498	{	496	{
499	return type (p) == T_PROMISE;	497	return type (p) == T_PROMISE;
500	}	498	}
501		499
502	INTERFACE INLINE int	500	INTERFACE int
503	is_environment (pointer p)	501	is_environment (pointer p)
504	{	502	{
505	return type (p) == T_ENVIRONMENT;	503	return type (p) == T_ENVIRONMENT;
506	}	504	}
507		505
…		…
513		511
514	#define is_mark(p) (typeflag (p) & T_MARK)	512	#define is_mark(p) (typeflag (p) & T_MARK)
515	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	513	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
516	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	514	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
517		515
518	INTERFACE INLINE int	516	INTERFACE int
519	is_immutable (pointer p)	517	is_immutable (pointer p)
520	{	518	{
521	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	519	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
522	}	520	}
523		521
524	INTERFACE INLINE void	522	INTERFACE void
525	setimmutable (pointer p)	523	setimmutable (pointer p)
526	{	524	{
527	#if USE_ERROR_CHECKING	525	#if USE_ERROR_CHECKING
528	set_typeflag (p, typeflag (p) \| T_IMMUTABLE);	526	set_typeflag (p, typeflag (p) \| T_IMMUTABLE);
529	#endif	527	#endif
530	}	528	}
531		529
532	#if USE_CHAR_CLASSIFIERS	530	#if USE_CHAR_CLASSIFIERS
533	static INLINE int	531	ecb_inline int
534	Cisalpha (int c)	532	Cisalpha (int c)
535	{	533	{
536	return isascii (c) && isalpha (c);	534	return isascii (c) && isalpha (c);
537	}	535	}
538		536
539	static INLINE int	537	ecb_inline int
540	Cisdigit (int c)	538	Cisdigit (int c)
541	{	539	{
542	return isascii (c) && isdigit (c);	540	return isascii (c) && isdigit (c);
543	}	541	}
544		542
545	static INLINE int	543	ecb_inline int
546	Cisspace (int c)	544	Cisspace (int c)
547	{	545	{
548	return isascii (c) && isspace (c);	546	return isascii (c) && isspace (c);
549	}	547	}
550		548
551	static INLINE int	549	ecb_inline int
552	Cisupper (int c)	550	Cisupper (int c)
553	{	551	{
554	return isascii (c) && isupper (c);	552	return isascii (c) && isupper (c);
555	}	553	}
556		554
557	static INLINE int	555	ecb_inline int
558	Cislower (int c)	556	Cislower (int c)
559	{	557	{
560	return isascii (c) && islower (c);	558	return isascii (c) && islower (c);
561	}	559	}
562	#endif	560	#endif
…		…
623	#endif	621	#endif
624		622
625	static int file_push (SCHEME_P_ const char *fname);	623	static int file_push (SCHEME_P_ const char *fname);
626	static void file_pop (SCHEME_P);	624	static void file_pop (SCHEME_P);
627	static int file_interactive (SCHEME_P);	625	static int file_interactive (SCHEME_P);
628	static INLINE int is_one_of (char *s, int c);	626	ecb_inline int is_one_of (char *s, int c);
629	static int alloc_cellseg (SCHEME_P_ int n);	627	static int alloc_cellseg (SCHEME_P_ int n);
630	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	628	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
631	static void finalize_cell (SCHEME_P_ pointer a);	629	static void finalize_cell (SCHEME_P_ pointer a);
632	static int count_consecutive_cells (pointer x, int needed);	630	static int count_consecutive_cells (pointer x, int needed);
633	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	631	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
634	static pointer mk_number (SCHEME_P_ const num n);	632	static pointer mk_number (SCHEME_P_ const num n);
635	static char store_string (SCHEME_P_ uint32_t len, const char str, char fill);	633	static char store_string (SCHEME_P_ uint32_t len, const char str, char fill);
…		…
652	static int basic_inchar (port *pt);	650	static int basic_inchar (port *pt);
653	static int inchar (SCHEME_P);	651	static int inchar (SCHEME_P);
654	static void backchar (SCHEME_P_ int c);	652	static void backchar (SCHEME_P_ int c);
655	static char readstr_upto (SCHEME_P_ char delim);	653	static char readstr_upto (SCHEME_P_ char delim);
656	static pointer readstrexp (SCHEME_P);	654	static pointer readstrexp (SCHEME_P);
657	static INLINE int skipspace (SCHEME_P);	655	ecb_inline int skipspace (SCHEME_P);
658	static int token (SCHEME_P);	656	static int token (SCHEME_P);
659	static void printslashstring (SCHEME_P_ char *s, int len);	657	static void printslashstring (SCHEME_P_ char *s, int len);
660	static void atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen);	658	static void atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen);
661	static void printatom (SCHEME_P_ pointer l, int f);	659	static void printatom (SCHEME_P_ pointer l, int f);
662	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	660	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
666	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);	664	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
667	static pointer revappend (SCHEME_P_ pointer a, pointer b);	665	static pointer revappend (SCHEME_P_ pointer a, pointer b);
668	static pointer ss_get_cont (SCHEME_P);	666	static pointer ss_get_cont (SCHEME_P);
669	static void ss_set_cont (SCHEME_P_ pointer cont);	667	static void ss_set_cont (SCHEME_P_ pointer cont);
670	static void dump_stack_mark (SCHEME_P);	668	static void dump_stack_mark (SCHEME_P);
671	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);	669	static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
		670	static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
672	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	671	static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
673	static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
674	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);	672	static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
675	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	673	static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
676	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	674	static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
677	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	675	static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
678	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	676	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
679	static void assign_syntax (SCHEME_P_ const char *name);	677	static void assign_syntax (SCHEME_P_ const char *name);
680	static int syntaxnum (pointer p);	678	static int syntaxnum (pointer p);
681	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	679	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
682		680
…		…
780		778
781	num_set_ivalue (ret, res);	779	num_set_ivalue (ret, res);
782	return ret;	780	return ret;
783	}	781	}
784		782
785	/* this completely disrespects NaNs */	783	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
786	static int	784	static int
787	num_cmp (num a, num b)	785	num_cmp (num a, num b)
788	{	786	{
789	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	787	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
790	int ret;	788	int ret;
…		…
833	#endif	831	#endif
834		832
835	static int	833	static int
836	is_zero_rvalue (RVALUE x)	834	is_zero_rvalue (RVALUE x)
837	{	835	{
		836	return x == 0;
		837	#if 0
838	#if USE_REAL	838	#if USE_REAL
839	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	839	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
840	#else	840	#else
841	return x == 0;	841	return x == 0;
		842	#endif
842	#endif	843	#endif
843	}	844	}
844		845
845	/* allocate new cell segment */	846	/* allocate new cell segment */
846	static int	847	static int
…		…
918		919
919	return n;	920	return n;
920	}	921	}
921		922
922	/* get new cell. parameter a, b is marked by gc. */	923	/* get new cell. parameter a, b is marked by gc. */
923	static INLINE pointer	924	ecb_inline pointer
924	get_cell_x (SCHEME_P_ pointer a, pointer b)	925	get_cell_x (SCHEME_P_ pointer a, pointer b)
925	{	926	{
926	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	927	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
927	{	928	{
928	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	929	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1006	push_recent_alloc (SCHEME_A_ v, NIL);	1007	push_recent_alloc (SCHEME_A_ v, NIL);
1007		1008
1008	return v;	1009	return v;
1009	}	1010	}
1010		1011
1011	static INLINE void	1012	ecb_inline void
1012	ok_to_freely_gc (SCHEME_P)	1013	ok_to_freely_gc (SCHEME_P)
1013	{	1014	{
1014	set_car (S_SINK, NIL);	1015	set_car (S_SINK, NIL);
1015	}	1016	}
1016		1017
…		…
1080	location = hash_fn (name, veclength (SCHEME_V->oblist));	1081	location = hash_fn (name, veclength (SCHEME_V->oblist));
1081	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));	1082	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1082	return x;	1083	return x;
1083	}	1084	}
1084		1085
1085	static INLINE pointer	1086	ecb_inline pointer
1086	oblist_find_by_name (SCHEME_P_ const char *name)	1087	oblist_find_by_name (SCHEME_P_ const char *name)
1087	{	1088	{
1088	int location;	1089	int location;
1089	pointer x;	1090	pointer x;
1090	char *s;	1091	char *s;
…		…
1123	oblist_initial_value (SCHEME_P)	1124	oblist_initial_value (SCHEME_P)
1124	{	1125	{
1125	return NIL;	1126	return NIL;
1126	}	1127	}
1127		1128
1128	static INLINE pointer	1129	ecb_inline pointer
1129	oblist_find_by_name (SCHEME_P_ const char *name)	1130	oblist_find_by_name (SCHEME_P_ const char *name)
1130	{	1131	{
1131	pointer x;	1132	pointer x;
1132	char *s;	1133	char *s;
1133		1134
…		…
2231	}	2232	}
2232	}	2233	}
2233	}	2234	}
2234		2235
2235	/* check c is in chars */	2236	/* check c is in chars */
2236	static INLINE int	2237	ecb_inline int
2237	is_one_of (char *s, int c)	2238	is_one_of (char *s, int c)
2238	{	2239	{
2239	if (c == EOF)	2240	if (c == EOF)
2240	return 1;	2241	return 1;
2241		2242
2242	return !!strchr (s, c);	2243	return !!strchr (s, c);
2243	}	2244	}
2244		2245
2245	/* skip white characters */	2246	/* skip white characters */
2246	static INLINE int	2247	ecb_inline int
2247	skipspace (SCHEME_P)	2248	skipspace (SCHEME_P)
2248	{	2249	{
2249	int c, curr_line = 0;	2250	int c, curr_line = 0;
2250		2251
2251	do	2252	do
…		…
2822		2823
2823	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2824	setenvironment (SCHEME_V->envir);	2825	setenvironment (SCHEME_V->envir);
2825	}	2826	}
2826		2827
2827	static INLINE void	2828	ecb_inline void
2828	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2829	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2829	{	2830	{
2830	pointer slot = immutable_cons (variable, value);	2831	pointer slot = immutable_cons (variable, value);
2831		2832
2832	if (is_vector (car (env)))	2833	if (is_vector (car (env)))
…		…
2872	return NIL;	2873	return NIL;
2873	}	2874	}
2874		2875
2875	#else /* USE_ALIST_ENV */	2876	#else /* USE_ALIST_ENV */
2876		2877
2877	static INLINE void	2878	ecb_inline void
2878	new_frame_in_env (SCHEME_P_ pointer old_env)	2879	new_frame_in_env (SCHEME_P_ pointer old_env)
2879	{	2880	{
2880	SCHEME_V->envir = immutable_cons (NIL, old_env);	2881	SCHEME_V->envir = immutable_cons (NIL, old_env);
2881	setenvironment (SCHEME_V->envir);	2882	setenvironment (SCHEME_V->envir);
2882	}	2883	}
2883		2884
2884	static INLINE void	2885	ecb_inline void
2885	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2886	{	2887	{
2887	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2888	}	2889	}
2889		2890
…		…
2911	return NIL;	2912	return NIL;
2912	}	2913	}
2913		2914
2914	#endif /* USE_ALIST_ENV else */	2915	#endif /* USE_ALIST_ENV else */
2915		2916
2916	static INLINE void	2917	ecb_inline void
2917	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2918	{	2919	{
2919	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2920	}	2921	}
2921		2922
2922	static INLINE void	2923	ecb_inline void
2923	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2924	{	2925	{
2925	set_cdr (slot, value);	2926	set_cdr (slot, value);
2926	}	2927	}
2927		2928
2928	static INLINE pointer	2929	ecb_inline pointer
2929	slot_value_in_env (pointer slot)	2930	slot_value_in_env (pointer slot)
2930	{	2931	{
2931	return cdr (slot);	2932	return cdr (slot);
2932	}	2933	}
2933		2934
2934	/* ========== Evaluation Cycle ========== */	2935	/* ========== Evaluation Cycle ========== */
2935		2936
2936	static pointer	2937	static int
2937	xError_1 (SCHEME_P_ const char *s, pointer a)	2938	xError_1 (SCHEME_P_ const char *s, pointer a)
2938	{	2939	{
2939	#if USE_ERROR_HOOK	2940	#if USE_ERROR_HOOK
2940	pointer x;	2941	pointer x;
2941	pointer hdl = SCHEME_V->ERROR_HOOK;	2942	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
2976	code = cons (mk_string (SCHEME_A_ s), code);	2977	code = cons (mk_string (SCHEME_A_ s), code);
2977	setimmutable (car (code));	2978	setimmutable (car (code));
2978	SCHEME_V->code = cons (slot_value_in_env (x), code);	2979	SCHEME_V->code = cons (slot_value_in_env (x), code);
2979	SCHEME_V->op = OP_EVAL;	2980	SCHEME_V->op = OP_EVAL;
2980		2981
2981	return S_T;	2982	return 0;
2982	}	2983	}
2983	#endif	2984	#endif
2984		2985
2985	if (a)	2986	if (a)
2986	SCHEME_V->args = cons (a, NIL);	2987	SCHEME_V->args = cons (a, NIL);
…		…
2988	SCHEME_V->args = NIL;	2989	SCHEME_V->args = NIL;
2989		2990
2990	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);	2991	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2991	setimmutable (car (SCHEME_V->args));	2992	setimmutable (car (SCHEME_V->args));
2992	SCHEME_V->op = OP_ERR0;	2993	SCHEME_V->op = OP_ERR0;
		2994
2993	return S_T;	2995	return 0;
2994	}	2996	}
2995		2997
2996	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)	2998	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2997	#define Error_0(s) Error_1 (s, 0)	2999	#define Error_0(s) Error_1 (s, 0)
2998		3000
2999	/* Too small to turn into function */	3001	/* Too small to turn into function */
3000	#define BEGIN do {	3002	#define BEGIN do {
3001	#define END } while (0)	3003	#define END } while (0)
3002	#define s_goto(a) BEGIN \	3004	#define s_goto(a) BEGIN \
3003	SCHEME_V->op = a; \	3005	SCHEME_V->op = a; \
3004	return S_T; END	3006	return 0; END
3005		3007
3006	#define s_return(a) return xs_return (SCHEME_A_ a)	3008	#define s_return(a) return xs_return (SCHEME_A_ a)
3007		3009
3008	#ifndef USE_SCHEME_STACK	3010	#ifndef USE_SCHEME_STACK
3009		3011
…		…
3039	next_frame->code = code;	3041	next_frame->code = code;
3040		3042
3041	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3043	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3042	}	3044	}
3043		3045
3044	static pointer	3046	static int
3045	xs_return (SCHEME_P_ pointer a)	3047	xs_return (SCHEME_P_ pointer a)
3046	{	3048	{
3047	int nframes = (uintptr_t)SCHEME_V->dump;	3049	int nframes = (uintptr_t)SCHEME_V->dump;
3048	struct dump_stack_frame *frame;	3050	struct dump_stack_frame *frame;
3049		3051
3050	SCHEME_V->value = a;	3052	SCHEME_V->value = a;
3051		3053
3052	if (nframes <= 0)	3054	if (nframes <= 0)
3053	return NIL;	3055	return -1;
3054		3056
3055	frame = &SCHEME_V->dump_base[--nframes];	3057	frame = &SCHEME_V->dump_base[--nframes];
3056	SCHEME_V->op = frame->op;	3058	SCHEME_V->op = frame->op;
3057	SCHEME_V->args = frame->args;	3059	SCHEME_V->args = frame->args;
3058	SCHEME_V->envir = frame->envir;	3060	SCHEME_V->envir = frame->envir;
3059	SCHEME_V->code = frame->code;	3061	SCHEME_V->code = frame->code;
3060	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3061		3063
3062	return S_T;	3064	return 0;
3063	}	3065	}
3064		3066
3065	static INLINE void	3067	ecb_inline void
3066	dump_stack_reset (SCHEME_P)	3068	dump_stack_reset (SCHEME_P)
3067	{	3069	{
3068	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3069	SCHEME_V->dump = (pointer)+0;	3071	SCHEME_V->dump = (pointer)+0;
3070	}	3072	}
3071		3073
3072	static INLINE void	3074	ecb_inline void
3073	dump_stack_initialize (SCHEME_P)	3075	dump_stack_initialize (SCHEME_P)
3074	{	3076	{
3075	SCHEME_V->dump_size = 0;	3077	SCHEME_V->dump_size = 0;
3076	SCHEME_V->dump_base = 0;	3078	SCHEME_V->dump_base = 0;
3077	dump_stack_reset (SCHEME_A);	3079	dump_stack_reset (SCHEME_A);
…		…
3144	SCHEME_V->dump = (pointer)(uintptr_t)i;	3146	SCHEME_V->dump = (pointer)(uintptr_t)i;
3145	}	3147	}
3146		3148
3147	#else	3149	#else
3148		3150
3149	static INLINE void	3151	ecb_inline void
3150	dump_stack_reset (SCHEME_P)	3152	dump_stack_reset (SCHEME_P)
3151	{	3153	{
3152	SCHEME_V->dump = NIL;	3154	SCHEME_V->dump = NIL;
3153	}	3155	}
3154		3156
3155	static INLINE void	3157	ecb_inline void
3156	dump_stack_initialize (SCHEME_P)	3158	dump_stack_initialize (SCHEME_P)
3157	{	3159	{
3158	dump_stack_reset (SCHEME_A);	3160	dump_stack_reset (SCHEME_A);
3159	}	3161	}
3160		3162
…		…
3162	dump_stack_free (SCHEME_P)	3164	dump_stack_free (SCHEME_P)
3163	{	3165	{
3164	SCHEME_V->dump = NIL;	3166	SCHEME_V->dump = NIL;
3165	}	3167	}
3166		3168
3167	static pointer	3169	static int
3168	xs_return (SCHEME_P_ pointer a)	3170	xs_return (SCHEME_P_ pointer a)
3169	{	3171	{
3170	pointer dump = SCHEME_V->dump;	3172	pointer dump = SCHEME_V->dump;
3171		3173
3172	SCHEME_V->value = a;	3174	SCHEME_V->value = a;
3173		3175
3174	if (dump == NIL)	3176	if (dump == NIL)
3175	return NIL;	3177	return -1;
3176		3178
3177	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3178	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3179	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3180	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3181		3183
3182	SCHEME_V->dump = dump;	3184	SCHEME_V->dump = dump;
3183		3185
3184	return S_T;	3186	return 0;
3185	}	3187	}
3186		3188
3187	static void	3189	static void
3188	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3190	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3189	{	3191	{
…		…
3214		3216
3215	#endif	3217	#endif
3216		3218
3217	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3219	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3218		3220
3219	static pointer	3221	static int
3220	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3222	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3221	{	3223	{
3222	pointer args = SCHEME_V->args;	3224	pointer args = SCHEME_V->args;
3223	pointer x, y;	3225	pointer x, y;
3224		3226
…		…
3910	SCHEME_V->code = car (args);	3912	SCHEME_V->code = car (args);
3911	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3912	s_goto (OP_APPLY);	3914	s_goto (OP_APPLY);
3913	}	3915	}
3914		3916
3915	abort ();	3917	if (USE_ERROR_CHECKING) abort ();
3916	}	3918	}
3917		3919
3918	static pointer	3920	static int
3919	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3920	{	3922	{
3921	pointer args = SCHEME_V->args;	3923	pointer args = SCHEME_V->args;
3922	pointer x = car (args);	3924	pointer x = car (args);
3923	num v;	3925	num v;
3924		3926
…		…
4013		4015
4014	case OP_ADD: /* + */	4016	case OP_ADD: /* + */
4015	v = num_zero;	4017	v = num_zero;
4016		4018
4017	for (x = args; x != NIL; x = cdr (x))	4019	for (x = args; x != NIL; x = cdr (x))
4018	v = num_op ('+', v, nvalue (car (x)));	4020	v = num_op (NUM_ADD, v, nvalue (car (x)));
4019		4021
4020	s_return (mk_number (SCHEME_A_ v));	4022	s_return (mk_number (SCHEME_A_ v));
4021		4023
4022	case OP_MUL: /* * */	4024	case OP_MUL: /* * */
4023	v = num_one;	4025	v = num_one;
4024		4026
4025	for (x = args; x != NIL; x = cdr (x))	4027	for (x = args; x != NIL; x = cdr (x))
4026	v = num_op ('+', v, nvalue (car (x)));	4028	v = num_op (NUM_MUL, v, nvalue (car (x)));
4027		4029
4028	s_return (mk_number (SCHEME_A_ v));	4030	s_return (mk_number (SCHEME_A_ v));
4029		4031
4030	case OP_SUB: /* - */	4032	case OP_SUB: /* - */
4031	if (cdr (args) == NIL)	4033	if (cdr (args) == NIL)
…		…
4038	x = cdr (args);	4040	x = cdr (args);
4039	v = nvalue (car (args));	4041	v = nvalue (car (args));
4040	}	4042	}
4041		4043
4042	for (; x != NIL; x = cdr (x))	4044	for (; x != NIL; x = cdr (x))
4043	v = num_op ('+', v, nvalue (car (x)));	4045	v = num_op (NUM_SUB, v, nvalue (car (x)));
4044		4046
4045	s_return (mk_number (SCHEME_A_ v));	4047	s_return (mk_number (SCHEME_A_ v));
4046		4048
4047	case OP_DIV: /* / */	4049	case OP_DIV: /* / */
4048	if (cdr (args) == NIL)	4050	if (cdr (args) == NIL)
…		…
4055	x = cdr (args);	4057	x = cdr (args);
4056	v = nvalue (car (args));	4058	v = nvalue (car (args));
4057	}	4059	}
4058		4060
4059	for (; x != NIL; x = cdr (x))	4061	for (; x != NIL; x = cdr (x))
4060	{
4061	if (!is_zero_rvalue (rvalue (car (x))))	4062	if (!is_zero_rvalue (rvalue (car (x))))
4062	v = num_div (v, nvalue (car (x)));	4063	v = num_div (v, nvalue (car (x)));
4063	else	4064	else
4064	Error_0 ("/: division by zero");	4065	Error_0 ("/: division by zero");
4065	}
4066		4066
4067	s_return (mk_number (SCHEME_A_ v));	4067	s_return (mk_number (SCHEME_A_ v));
4068		4068
4069	case OP_INTDIV: /* quotient */	4069	case OP_INTDIV: /* quotient */
4070	if (cdr (args) == NIL)	4070	if (cdr (args) == NIL)
…		…
4079	}	4079	}
4080		4080
4081	for (; x != NIL; x = cdr (x))	4081	for (; x != NIL; x = cdr (x))
4082	{	4082	{
4083	if (ivalue (car (x)) != 0)	4083	if (ivalue (car (x)) != 0)
4084	v = num_op ('/', v, nvalue (car (x)));	4084	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4085	else	4085	else
4086	Error_0 ("quotient: division by zero");	4086	Error_0 ("quotient: division by zero");
4087	}	4087	}
4088		4088
4089	s_return (mk_number (SCHEME_A_ v));	4089	s_return (mk_number (SCHEME_A_ v));
…		…
4417	set_vector_elem (x, index, caddr (args));	4417	set_vector_elem (x, index, caddr (args));
4418	s_return (x);	4418	s_return (x);
4419	}	4419	}
4420	}	4420	}
4421		4421
4422	return S_T;	4422	if (USE_ERROR_CHECKING) abort ();
4423	}	4423	}
4424		4424
4425	INTERFACE int	4425	INTERFACE int
4426	is_list (SCHEME_P_ pointer a)	4426	is_list (SCHEME_P_ pointer a)
4427	{	4427	{
…		…
4474	return -1;	4474	return -1;
4475	}	4475	}
4476	}	4476	}
4477	}	4477	}
4478		4478
4479	static pointer	4479	static int
4480	opexe_r (SCHEME_P_ enum scheme_opcodes op)	4480	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4481	{	4481	{
4482	pointer x = SCHEME_V->args;	4482	pointer x = SCHEME_V->args;
4483		4483
4484	for (;;)	4484	for (;;)
4485	{	4485	{
…		…
4505	}	4505	}
4506		4506
4507	s_return (S_T);	4507	s_return (S_T);
4508	}	4508	}
4509		4509
4510	static pointer	4510	static int
4511	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4511	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4512	{	4512	{
4513	pointer args = SCHEME_V->args;	4513	pointer args = SCHEME_V->args;
4514	pointer a = car (args);	4514	pointer a = car (args);
4515	pointer d = cdr (args);	4515	pointer d = cdr (args);
…		…
4561	}	4561	}
4562		4562
4563	s_retbool (r);	4563	s_retbool (r);
4564	}	4564	}
4565		4565
4566	static pointer	4566	static int
4567	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4567	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4568	{	4568	{
4569	pointer args = SCHEME_V->args;	4569	pointer args = SCHEME_V->args;
4570	pointer a = car (args);	4570	pointer a = car (args);
4571	pointer x, y;	4571	pointer x, y;
…		…
4657	putstr (SCHEME_A_ "\n");	4657	putstr (SCHEME_A_ "\n");
4658		4658
4659	if (SCHEME_V->interactive_repl)	4659	if (SCHEME_V->interactive_repl)
4660	s_goto (OP_T0LVL);	4660	s_goto (OP_T0LVL);
4661	else	4661	else
4662	return NIL;	4662	return -1;
4663	}	4663	}
4664		4664
4665	case OP_REVERSE: /* reverse */	4665	case OP_REVERSE: /* reverse */
4666	s_return (reverse (SCHEME_A_ a));	4666	s_return (reverse (SCHEME_A_ a));
4667		4667
…		…
4724		4724
4725	case OP_QUIT: /* quit */	4725	case OP_QUIT: /* quit */
4726	if (is_pair (args))	4726	if (is_pair (args))
4727	SCHEME_V->retcode = ivalue (a);	4727	SCHEME_V->retcode = ivalue (a);
4728		4728
4729	return NIL;	4729	return -1;
4730		4730
4731	case OP_GC: /* gc */	4731	case OP_GC: /* gc */
4732	gc (SCHEME_A_ NIL, NIL);	4732	gc (SCHEME_A_ NIL, NIL);
4733	s_return (S_T);	4733	s_return (S_T);
4734		4734
…		…
4781	break;	4781	break;
4782	}	4782	}
4783		4783
4784	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4784	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4785		4785
4786	if (p == NIL)	4786	s_return (p == NIL ? S_F : p);
4787	s_return (S_F);
4788
4789	s_return (p);
4790	}	4787	}
4791		4788
4792	# if USE_STRING_PORTS	4789	# if USE_STRING_PORTS
4793		4790
4794	case OP_OPEN_INSTRING: /* open-input-string */	4791	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4809	}	4806	}
4810		4807
4811	p = port_from_string (SCHEME_A_ strvalue (a),	4808	p = port_from_string (SCHEME_A_ strvalue (a),
4812	strvalue (a) + strlength (a), prop);	4809	strvalue (a) + strlength (a), prop);
4813		4810
4814	if (p == NIL)	4811	s_return (p == NIL ? S_F : p);
4815	s_return (S_F);
4816
4817	s_return (p);
4818	}	4812	}
4819		4813
4820	case OP_OPEN_OUTSTRING: /* open-output-string */	4814	case OP_OPEN_OUTSTRING: /* open-output-string */
4821	{	4815	{
4822	pointer p;	4816	pointer p;
4823		4817
4824	if (a == NIL)	4818	if (a == NIL)
4825	{
4826	p = port_from_scratch (SCHEME_A);	4819	p = port_from_scratch (SCHEME_A);
4827
4828	if (p == NIL)
4829	s_return (S_F);
4830	}
4831	else	4820	else
4832	{
4833	p = port_from_string (SCHEME_A_ strvalue (a),	4821	p = port_from_string (SCHEME_A_ strvalue (a),
4834	strvalue (a) + strlength (a), port_output);	4822	strvalue (a) + strlength (a), port_output);
4835		4823
4836	if (p == NIL)	4824	s_return (p == NIL ? S_F : p);
4837	s_return (S_F);
4838	}
4839
4840	s_return (p);
4841	}	4825	}
4842		4826
4843	case OP_GET_OUTSTRING: /* get-output-string */	4827	case OP_GET_OUTSTRING: /* get-output-string */
4844	{	4828	{
4845	port *p;	4829	port *p;
…		…
4884	case OP_CURR_ENV: /* current-environment */	4868	case OP_CURR_ENV: /* current-environment */
4885	s_return (SCHEME_V->envir);	4869	s_return (SCHEME_V->envir);
4886		4870
4887	}	4871	}
4888		4872
4889	abort ();	4873	if (USE_ERROR_CHECKING) abort ();
4890	}	4874	}
4891		4875
4892	static pointer	4876	static int
4893	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4877	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4894	{	4878	{
4895	pointer args = SCHEME_V->args;	4879	pointer args = SCHEME_V->args;
4896	pointer x;	4880	pointer x;
4897		4881
…		…
5227	s_goto (OP_P0LIST);	5211	s_goto (OP_P0LIST);
5228	}	5212	}
5229	}	5213	}
5230	}	5214	}
5231		5215
5232	abort ();	5216	if (USE_ERROR_CHECKING) abort ();
5233	}	5217	}
5234		5218
5235	static pointer	5219	static int
5236	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5220	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5237	{	5221	{
5238	pointer args = SCHEME_V->args;	5222	pointer args = SCHEME_V->args;
5239	pointer a = car (args);	5223	pointer a = car (args);
5240	pointer x, y;	5224	pointer x, y;
…		…
5290		5274
5291	case OP_MACROP: /* macro? */	5275	case OP_MACROP: /* macro? */
5292	s_retbool (is_macro (a));	5276	s_retbool (is_macro (a));
5293	}	5277	}
5294		5278
5295	abort ();	5279	if (USE_ERROR_CHECKING) abort ();
5296	}	5280	}
5297		5281
		5282	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5298	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);	5283	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5299		5284
5300	typedef int (*test_predicate) (pointer);	5285	typedef int (*test_predicate)(pointer);
5301	static int	5286	static int
5302	is_any (pointer p)	5287	is_any (pointer p)
5303	{	5288	{
5304	return 1;	5289	return 1;
5305	}	5290	}
5306		5291
5307	static int	5292	static int
5308	is_nonneg (pointer p)	5293	is_nonneg (pointer p)
5309	{	5294	{
5310	return ivalue (p) >= 0 && is_integer (p);	5295	return ivalue (p) >= 0 && is_integer (p);
		5296	}
		5297
		5298	static int
		5299	tst_is_list (pointer p)
		5300	{
		5301	return p == NIL \|\| is_pair (p);
5311	}	5302	}
5312		5303
5313	/* Correspond carefully with following defines! */	5304	/* Correspond carefully with following defines! */
5314	static struct	5305	static struct
5315	{	5306	{
5316	test_predicate fct;	5307	test_predicate fct;
5317	const char *kind;	5308	const char *kind;
5318	} tests[] =	5309	} tests[] =
5319	{	5310	{
5320	{ 0, 0}, /* unused */	5311	{ is_any, 0 },
5321	{ is_any, 0},	5312	{ is_string, "string" },
5322	{ is_string, "string" },	5313	{ is_symbol, "symbol" },
5323	{ is_symbol, "symbol" },	5314	{ is_port, "port" },
5324	{ is_port, "port" },
5325	{ is_inport, "input port" },	5315	{ is_inport, "input port" },
5326	{ is_outport, "output port" },	5316	{ is_outport, "output port" },
5327	{ is_environment, "environment" },	5317	{ is_environment, "environment" },
5328	{ is_pair, "pair" },	5318	{ is_pair, "pair" },
5329	{ 0, "pair or '()" },	5319	{ tst_is_list, "pair or '()" },
5330	{ is_character, "character" },	5320	{ is_character, "character" },
5331	{ is_vector, "vector" },	5321	{ is_vector, "vector" },
5332	{ is_number, "number" },	5322	{ is_number, "number" },
5333	{ is_integer, "integer" },	5323	{ is_integer, "integer" },
5334	{ is_nonneg, "non-negative integer" }	5324	{ is_nonneg, "non-negative integer" }
5335	};	5325	};
5336		5326
5337	#define TST_NONE 0 /* TST_NONE used for standard procedures, for internal ops, 0 is used */	5327	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5338	#define TST_ANY "\001"	5328	#define TST_ANY "\001"
5339	#define TST_STRING "\002"	5329	#define TST_STRING "\002"
5340	#define TST_SYMBOL "\003"	5330	#define TST_SYMBOL "\003"
5341	#define TST_PORT "\004"	5331	#define TST_PORT "\004"
5342	#define TST_INPORT "\005"	5332	#define TST_INPORT "\005"
…		…
5348	#define TST_VECTOR "\013"	5338	#define TST_VECTOR "\013"
5349	#define TST_NUMBER "\014"	5339	#define TST_NUMBER "\014"
5350	#define TST_INTEGER "\015"	5340	#define TST_INTEGER "\015"
5351	#define TST_NATURAL "\016"	5341	#define TST_NATURAL "\016"
5352		5342
		5343	#define INF_ARG 0xff
		5344	#define UNNAMED_OP ""
		5345
		5346	static const char opnames[] =
		5347	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
		5348	#include "opdefines.h"
		5349	#undef OP_DEF
		5350	;
		5351
		5352	static const char *
		5353	opname (int idx)
		5354	{
		5355	const char *name = opnames;
		5356
		5357	/* should do this at compile time, but would require external program, right? */
		5358	while (idx--)
		5359	name += strlen (name) + 1;
		5360
		5361	return *name ? name : "ILLEGAL";
		5362	}
		5363
		5364	static const char *
		5365	procname (pointer x)
		5366	{
		5367	return opname (procnum (x));
		5368	}
		5369
5353	typedef struct	5370	typedef struct
5354	{	5371	{
5355	dispatch_func func;	5372	uint8_t func;
5356	char *name;	5373	/dispatch_func func;//TODO: maybe optionally keep the pointer, for speed? /
		5374	uint8_t builtin;
5357	int min_arity;	5375	uint8_t min_arity;
5358	int max_arity;	5376	uint8_t max_arity;
5359	char arg_tests_encoding[3];	5377	char arg_tests_encoding[3];
5360	} op_code_info;	5378	} op_code_info;
5361		5379
5362	#define INF_ARG 0xffff
5363
5364	static op_code_info dispatch_table[] = {	5380	static const op_code_info dispatch_table[] = {
5365	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest },	5381	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5366	#include "opdefines.h"	5382	#include "opdefines.h"
5367	#undef OP_DEF	5383	#undef OP_DEF
5368	{0}	5384	{0}
5369	};	5385	};
5370		5386
5371	static const char *
5372	procname (pointer x)
5373	{
5374	int n = procnum (x);
5375	const char *name = dispatch_table[n].name;
5376
5377	if (name == 0)
5378	name = "ILLEGAL!";
5379
5380	return name;
5381	}
5382
5383	/* kernel of this interpreter */	5387	/* kernel of this interpreter */
5384	static void	5388	static void ecb_hot
5385	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5389	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5386	{	5390	{
5387	SCHEME_V->op = op;	5391	SCHEME_V->op = op;
5388		5392
5389	for (;;)	5393	for (;;)
5390	{	5394	{
5391	op_code_info *pcd = dispatch_table + SCHEME_V->op;	5395	const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5392		5396
5393	#if USE_ERROR_CHECKING	5397	#if USE_ERROR_CHECKING
5394	if (pcd->name) /* if built-in function, check arguments */	5398	if (pcd->builtin) /* if built-in function, check arguments */
5395	{	5399	{
5396	int ok = 1;
5397	char msg[STRBUFFSIZE];	5400	char msg[STRBUFFSIZE];
5398	int n = list_length (SCHEME_A_ SCHEME_V->args);	5401	int n = list_length (SCHEME_A_ SCHEME_V->args);
5399		5402
5400	/* Check number of arguments */	5403	/* Check number of arguments */
5401	if (ecb_expect_false (n < pcd->min_arity))	5404	if (ecb_expect_false (n < pcd->min_arity))
5402	{	5405	{
5403	ok = 0;
5404	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5406	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5405	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5407	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
		5408	xError_1 (SCHEME_A_ msg, 0);
		5409	continue;
5406	}	5410	}
5407	else if (ecb_expect_false (n > pcd->max_arity))	5411	else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5408	{	5412	{
5409	ok = 0;
5410	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5413	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5411	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5414	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
		5415	xError_1 (SCHEME_A_ msg, 0);
		5416	continue;
5412	}	5417	}
5413		5418	else
5414	if (ecb_expect_false (ok))
5415	{	5419	{
5416	if (*pcd->arg_tests_encoding)	5420	if (pcd->arg_tests_encoding) / literal 0 and TST_NONE treated the same */
5417	{	5421	{
5418	int i = 0;	5422	int i = 0;
5419	int j;	5423	int j;
5420	const char *t = pcd->arg_tests_encoding;	5424	const char *t = pcd->arg_tests_encoding;
5421	pointer arglist = SCHEME_V->args;	5425	pointer arglist = SCHEME_V->args;
…		…
5424	{	5428	{
5425	pointer arg = car (arglist);	5429	pointer arg = car (arglist);
5426		5430
5427	j = t[0];	5431	j = t[0];
5428		5432
5429	if (j == TST_LIST[0])	5433	if (!tests[j - 1].fct (arg))
5430	{
5431	if (arg != NIL && !is_pair (arg))
5432	break;	5434	break;
5433	}
5434	else
5435	{
5436	if (!tests[j].fct (arg))
5437	break;
5438	}
5439		5435
5440	if (t[1]) /* last test is replicated as necessary */	5436	if (t[1]) /* last test is replicated as necessary */
5441	t++;	5437	t++;
5442		5438
5443	arglist = cdr (arglist);	5439	arglist = cdr (arglist);
…		…
5445	}	5441	}
5446	while (i < n);	5442	while (i < n);
5447		5443
5448	if (i < n)	5444	if (i < n)
5449	{	5445	{
5450	ok = 0;
5451	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);	5446	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
		5447	xError_1 (SCHEME_A_ msg, 0);
		5448	continue;
5452	}	5449	}
5453	}	5450	}
5454	}	5451	}
5455
5456	if (!ok)
5457	{
5458	if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5459	return;
5460
5461	pcd = dispatch_table + SCHEME_V->op;
5462	}
5463	}	5452	}
5464	#endif	5453	#endif
5465		5454
5466	ok_to_freely_gc (SCHEME_A);	5455	ok_to_freely_gc (SCHEME_A);
5467		5456
		5457	static const dispatch_func dispatch_funcs[] = {
		5458	opexe_0,
		5459	opexe_1,
		5460	opexe_2,
		5461	opexe_3,
		5462	opexe_4,
		5463	opexe_5,
		5464	opexe_6,
		5465	};
		5466
5468	if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))	5467	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5469	return;	5468	return;
5470		5469
5471	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5470	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5472	{	5471	{
5473	xwrstr ("No memory!\n");	5472	xwrstr ("No memory!\n");
…		…
5572	return OP_C0STREAM; /* cons-stream */	5571	return OP_C0STREAM; /* cons-stream */
5573	}	5572	}
5574	}	5573	}
5575		5574
5576	#if USE_MULTIPLICITY	5575	#if USE_MULTIPLICITY
5577	scheme *	5576	ecb_cold scheme *
5578	scheme_init_new ()	5577	scheme_init_new ()
5579	{	5578	{
5580	scheme *sc = malloc (sizeof (scheme));	5579	scheme *sc = malloc (sizeof (scheme));
5581		5580
5582	if (!scheme_init (SCHEME_A))	5581	if (!scheme_init (SCHEME_A))
…		…
5587	else	5586	else
5588	return sc;	5587	return sc;
5589	}	5588	}
5590	#endif	5589	#endif
5591		5590
5592	int	5591	ecb_cold int
5593	scheme_init (SCHEME_P)	5592	scheme_init (SCHEME_P)
5594	{	5593	{
5595	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5594	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5596	pointer x;	5595	pointer x;
5597		5596
…		…
5670		5669
5671	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)	5670	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5672	assign_syntax (SCHEME_A_ syntax_names[i]);	5671	assign_syntax (SCHEME_A_ syntax_names[i]);
5673	}	5672	}
5674		5673
		5674	// TODO: should iterate via strlen, to avoid n² complexity
5675	for (i = 0; i < n; i++)	5675	for (i = 0; i < n; i++)
5676	if (dispatch_table[i].name != 0)	5676	if (dispatch_table[i].builtin)
5677	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5677	assign_proc (SCHEME_A_ i, opname (i));
5678		5678
5679	/* initialization of global pointers to special symbols */	5679	/* initialization of global pointers to special symbols */
5680	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5680	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5681	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5681	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5682	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5682	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
…		…
5721	scheme_set_external_data (SCHEME_P_ void *p)	5721	scheme_set_external_data (SCHEME_P_ void *p)
5722	{	5722	{
5723	SCHEME_V->ext_data = p;	5723	SCHEME_V->ext_data = p;
5724	}	5724	}
5725		5725
5726	void	5726	ecb_cold void
5727	scheme_deinit (SCHEME_P)	5727	scheme_deinit (SCHEME_P)
5728	{	5728	{
5729	int i;	5729	int i;
5730		5730
5731	#if SHOW_ERROR_LINE	5731	#if SHOW_ERROR_LINE

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.18 by root, Thu Nov 26 21:32:16 2015 UTC vs. Revision 1.24 by root, Fri Nov 27 02:12:08 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.18 by root, Thu Nov 26 21:32:16 2015 UTC vs.
Revision 1.24 by root, Fri Nov 27 02:12:08 2015 UTC