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

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